Browse Source

make it more quartiled

master
eta 3 months ago
parent
commit
22ef219ac5
  1. 77
      trackernet.lisp

77
trackernet.lisp

@ -1020,22 +1020,28 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Create links between subsequent observed track codes in ARCHIVED-TRAIN's history."
(destructuring-bind (filename archived-universal-ts train-key history)
archived-train
(declare (ignore filename archived-universal-ts train-key))
(loop
with first = (pop history)
for next = (pop history)
while next
do (let ((track-code-1 (track-code (third first)))
(track-code-2 (track-code (third next))))
(unless (gethash (list track-code-1 track-code-2) *track-links-set*)
(setf (gethash (list track-code-1 track-code-2) *track-links-set*) 0))
(incf (gethash (list track-code-1 track-code-2) *track-links-set*)))
(symbol-macrolet
((edge-count (gethash (list track-code-1 track-code-2) *track-links-set*)))
(unless edge-count
(setf edge-count 0))
(incf edge-count)
(when (eql (rem edge-count 100) 0)
(format t "~&* ~A -> ~A referenced ~A times~%"
track-code-1 track-code-2 edge-count))))
do (setf first next))))
(defun calculate-exponential-base (max top)
(expt top
(/ 1 max)))
(defun track-links-third-quartile (&key (cutoff 0))
(defun track-links-quartiles (&key (cutoff 0))
(let ((data (sort (loop
for v being the hash-values of *track-links-set*
unless (< v cutoff)
@ -1043,9 +1049,11 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
#'<)))
(values
(elt data
(* 3
(* 1
(floor (length data) 4)))
data)))
(elt data
(* 3
(floor (length data) 4))))))
(defun squish-link-length (in max top &optional (base (calculate-exponential-base max top)))
(cond
@ -1068,28 +1076,28 @@ layout = \"neato\";")
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(let* ((q3 (track-links-third-quartile :cutoff 5))
(base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v 5)
(string= a b))
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A%)\" color=\"0.0 0.0 ~F\" fontcolor=\"0.0 0.0 ~F\" style=\"~A\"];~%"
a
b
score-perc
(- 3.5 score-2)
v
score-perc
(+ 0.2 (/ (- 100 score-perc) 120))
(/ (- 100 score-perc) 100)
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid"))))))
(multiple-value-bind (q1 q3) (track-links-quartiles :cutoff 5)
(let* ((base (calculate-exponential-base q3 3)))
(loop
for (a b) being the hash-keys of *track-links-set*
using (hash-value v)
unless (or (< v q1)
(string= a b))
do (let* ((score-2 (1- (squish-link-length v q3 3 base)))
(score-perc (floor (* 50 score-2))))
(format out "\"~A\" -> \"~A\" [weight=~A len=~F label=\"~A (~A%)\" color=\"0.0 0.0 ~F\" fontcolor=\"0.0 0.0 ~F\" style=\"~A\"];~%"
a
b
score-perc
(- 3.5 score-2)
v
score-perc
(+ 0.2 (/ (- 100 score-perc) 120))
(/ (- 100 score-perc) 100)
(cond
((> score-perc 80) "bold")
((< score-perc 20) "dotted")
(t "solid")))))))
(princ "}" out))
@ -1134,3 +1142,16 @@ color=lightblue;
(string= a b))
do (format out "\"~A\" -> \"~A\" [weight=~A label=\"~A\"];~%" a b v v))
(princ "}" out))
(defun populate-track-links (train-list)
(reset-track-links-set)
(loop
for train in train-list
do (format t "~&*** Processing train ~A...~%" train)
do (unarchive-trains-tar train #'populate-track-links-set))
(format t "~&*** Done; ~A links~%" (hash-table-size *track-links-set*)))
(defun write-track-links-graphviz-to-file (outfile)
(with-open-file (out outfile
:direction :output)
(write-track-links-graphviz out)))
Loading…
Cancel
Save