FM Group -- network draw

fm_draw.lisp

#|
Konwertuje plik z opisem drzewa współpracowników FM Group[1] (plik *.csv; patrz: +datafile+)
do języka dot[2].

Linki:
[1] http://www.perfumy.fm/inc/tree2.php
[2] http://www.graphviz.org/
|#

(declaim (optimize (speed 3) (compilation-speed 0) (safety 0) (debug 0)))

;;; Parametry programu
;; Stała wskazująca plik *.csv z danymi
(defparameter +drzewo-filename+ "drzewko aktualne.csv")	
;; Czas na zapoznanie się z biznesem oraz kolory bazujące na tym parametrze
(defparameter +startup-time+ 14)
(defparameter +newbie-colour+ "\"\#41924B\"")
(defparameter +nonactive-colour+ "\"\#FF3333\"")
;; Kolory poziomów http://www.colourlovers.com/palette/244473/zen_persimmon . Po dodaniu kolorów przejściowych: http://tinyurl.com/3676gks
(defparameter  +3-colour+ "\"\#D8D8C0\"")
(defparameter  +6-colour+ "\"\#A9AD98\"")
(defparameter  +9-colour+ "\"\#7A8370\"")
(defparameter +12-colour+ "\"\#AC8442\"")
(defparameter +15-colour+ "\"\#DF8615\"")
(defparameter +18-colour+ "\"\#EB660A\"")
(defparameter +21-colour+ "\"\#F84600\"")

;;; Obliczanie ilości dni od wejścia danej osoby do struktury.
;(defconstant month-sums (nreverse (maplist #'(lambda(x) (apply #'+ x)) (nreverse '(0 31 28 31 30 31 30 31 31 30 31 30 31)))))
(defconstant month-sums #(0 31 59 90 120 151 181 212 243 273 304 334 365))
(defconstant yzero 1990)
(defparameter curr-d 0)
(defparameter curr-m 0)
(defparameter curr-y 0)
(defun leap? (y)
	(and (zerop (mod y 4))
		 (or (zerop (mod y 400))
			 (not (zerop (mod y 100))))))
(defun month->num (m y)
	(+ (svref month-sums (- m 1))
	   (if (and (> m 2) (leap? y)) 1 0)))
(defun year-days (y)
		(if (leap? y) 366 365))
(defun year->num (y)
	(let ((d 0))
		(if (>= y yzero)
			(dotimes (i (- y yzero) d)
				(incf d (year-days (+ yzero i))))
			(dotimes (i (- yzero y) (- d))
				(incf d (year-days (+ y i)))))))
(defun date->num (d m y)
	(+ (- d 1) (month->num m y) (year->num y) (- 21)))
(defun days-since (d1 m1 y1 d2 m2 y2)
	(- (date->num d2 m2 y2) (date->num d1 m1 y1)))

;;; Konwersja stringa do liczby
(defmacro num (x)
	`(read-from-string ,x :junk-allowed t))

;;; Struktura przechowująca informacje o drzewie
(defstruct (node
		;; Funkcja wyświetlająca
		(:print-function (lambda (n stream depth)
			(declare (ignore depth))
			;;										   Imie	   Telefon		Obrót			        Zarobek
			;;										   | Nieaktywny ID		|	   Obrót wł.        |	   Zarobek na swoich
			;;										   | |  Mail	|  Data	|	   |	        Próg|	   |            Balans zarobków
			(format stream "\"~A\" [~%    ~Alabel = \"{~A~A ~A ~A | ~A ~A | ~,2F (+~,2F) b:~,2F | ~D% ~,2Fzl (~,2Fzl) b:~,2F}\"~%];~%
\"~A\" -> \"~A\" [ label = \"(~D)~A\"]~%;"
				(node-id n)			; 		"PL000000" [
				(cond ((and (node-nieakt n) (> (node-days n) +startup-time+))
							(format nil "color = ~A~%    penwidth = 2~%    "+nonactive-colour+))
					  ((node-nieakt n)
							(format nil "color = ~A~%    penwidth = 2~%    " +newbie-colour+))
					  ((> (node-obrgr n) 30000)
							(format nil "color = ~A~%    style = filled~%" +21-colour+))
					  ((> (node-obrgr n) 20400)
							(format nil "color = ~A~%    style = filled~%" +18-colour+))
					  ((> (node-obrgr n) 12000)
							(format nil "color = ~A~%    style = filled~%" +15-colour+))
					  ((> (node-obrgr n) 7200)
							(format nil "color = ~A~%    style = filled~%" +12-colour+))
					  ((> (node-obrgr n) 3600)
							(format nil "color = ~A~%    style = filled~%" +9-colour+))
					  ((> (node-obrgr n) 1200)
							(format nil "color = ~A~%    style = filled~%" +6-colour+))
					  ((> (node-obrgr n) 300)
							(format nil "color = ~A~%    style = filled~%" +3-colour+))
					  (t
							""))
				(node-imie n)		;		Grzegorz Brzeczyszczykiewicz Jr.
				(if (node-nieakt n) (format nil " (~D dni)" (node-days n)) "")
				(if (node-mail n) (format nil " | ~A " (node-mail n)) "")
									;		gbrzeczy@dot.com |
				(if (node-tel n) (format nil "| ~A" (node-tel n)) "")
				(node-id n)			;		PL000000
				(subseq (format nil "~A"(node-wst n)) 2)		;		2010-01-01
				(node-obrgr n)		;		0.00
				(node-obrwl n)		; 		(+0.00)
				(node-bal n)
				(truncate (node-pro n))	;	0%
				(if (> (node-obrwl n) 34.42) (node-zar n) 0.00)
									; 		0.00zl
				(if (> (node-obrwl n) 34.42) (node-zarwl n) 0.00)
									; 		(0.00zl)"
				(node-balzar n)
				(node-parid n)
				(node-id n)
				(node-childrentotal n)
				(if (or (eql (node-par n) nil) (equalp (node-parzar n) 0.00) (< (node-obrwl (node-par n)) 43.42))
					""
					(format nil "\\n~,2Fzl"(node-parzar n)))))))
	;; Zawartość struktury
	(id "")				; ID w systemie
	(imie "")			; Imię i nazwisko
	(mail "")			; Podany adres email
	(tel nil)			; Podany nr telefonu
	(obrwl 0.00)		; Obrót własny
	(obrgr 0.00)		; Obrót grupy (suma)
	(pro 0.00)			; Osiągnięty próg
	(bal 0)				; Współczynnik zrównoważenia drzewa
	(balzar 0)			; Współczynnik zrównoważenia zarobków
	(zar 0.00)			; Zarobek
	(zarwl 0.00)		; Zarobek osobisty
	(parzar 0.00)		; Zarobek osoby wyżej z danej grupy
	(wst "2010-01-01")	; Data wstąpienia
	(nieakt nil)		; Miesięcy nieaktywny
	(days 0)			; Dni w strukturze
	(children nil)		; Osoby niżej w strukturze.
	(childrentotal 0)	; Całkowita ilość osób niżej
	(par nil)			; Osoba wyżej w strukturze.
	(parid ""))			; ID osoby wyżej w strukturze

;;; Zamiana polskich znaków na miedzynarodowe odpowiedniki (zażółć gęślą jaźń -> zazolc gesla jazn),
;;; gdyz powoduja problemy z graphviz.
(defun unpolish (mystr)
	(dolist (chg '((#\ż #\z) (#\ó #\o) (#\ł #\l) (#\ć #\c) (#\ę #\e) (#\ś #\s) (#\ą #\a) (#\ź #\z) (#\ń #\n)
				   (#\Ż #\Z) (#\Ó #\O) (#\Ł #\L) (#\Ć #\C) (#\Ę #\E) (#\Ś #\S) (#\Ą #\A) (#\Ź #\Z) (#\Ń #\N)))
		(setf mystr (substitute (second chg) (first chg) mystr)))
	mystr)

;;; Zamiana znaku @ na \@ w adresie mailowym
(defun unmail (x)
	(let ((p (position #\@ x)))
		(if p (format nil "~A\@~A"
				(subseq x 0 p)
				(subseq x (+ p 1))))))

;;; Funkcje dzielenia napisu na tokeny.
(defun constituent (c) (lambda (x) (and (graphic-char-p x) (not (char= x c)))))
(defun tokens (str test &key (start 0))
	(let ((p1 (position-if test str :start start)))
		(if p1
			(let ((p2 (position-if #'(lambda (c) (not (funcall test c))) str :start p1)))
				(cons
					(subseq str p1 p2)
					(if p2 (tokens str test :start p2) nil)))
		nil)))

;;; Dodawanie osoby do drzewa
(defparameter root nil)
(defparameter curr nil)
(defun addn (new obj)
	(cond ((not obj) (setf root new) (setf curr root))
		  ((not (string= (node-id obj) (node-parid new)))
			 (addn new (node-par obj)))
		  (t (setf (node-par new) obj)
			 (push new (node-children obj))
			 (setf curr new))))

(defun sqr (x) (* x x))
(defun A (lst)
	(/ (apply #'+ lst)
	   (length lst)))
(defun sigma (lst)
	(sqrt (- (/ (apply #'+ (mapcar #'sqr lst)) (length lst)) (sqr (A lst)))))
(defun calc-bal (lst)
"Wyznaczanie współczynnika balansu. Autor wzoru: Radek Łazarz"
	(- 1 (/ (atan (* (+ 2 (exp (- (apply #'+ lst)))) (/ (sigma lst) (A lst)))) (/ PI 2))))
;;; DFS
(defun dfs (x)
	(if x (progn
			(if (node-par x) (setf (node-parzar x) (* 0.01 (node-obrgr x) (- (node-pro (node-par x)) (node-pro x)))))
			(setf (node-zarwl x) (* 0.01 (node-pro x) (node-obrwl x)))
			(setf (node-zar x) (node-zarwl x))
			(setf (node-childrentotal x) 1)
			(let ((chldnumlst nil) (chldzarlst nil))
				(dolist (ch (node-children x))
					(multiple-value-bind (chldzar chldtot) (dfs ch)
						(setf (node-zar x) (+ (node-zar x) chldzar))
						(setf (node-childrentotal x) (+ (node-childrentotal x) chldtot))
						(push chldtot chldnumlst)
						(push chldzar chldzarlst)))
				(if chldnumlst (setf (node-bal x) (calc-bal chldnumlst)))
				(if (> (- (node-zar x) (node-zarwl x)) 0) (setf (node-balzar x) (calc-bal chldzarlst))))
			(values (node-parzar x) (node-childrentotal x)))
		(values 0.0 0)))

;;; Wyświetlanie nagłówka pliku dot
(defun print-header (data godzina)
	(let ((dt (tokens data (constituent #\-))))
		(setf curr-y (num (first dt)))
		(setf curr-m (num (second dt)))
		(setf curr-d (num (third dt))))
	(format t "digraph \"~A ~A\" {~%node [~%    rankdir = LR~%    shape = Mrecord~%    fontsize = 16~%];~%
edge [~%    fontsize = 20~%];~2%"
		data godzina))

;;; Wyświetlanie drzewa
(defun print-tree (n)
	(if n (progn
				(print n)
				(dolist (ch (node-children n))
					(print-tree ch)))))

;;; Wyszukiwanie wzorca (algorytm KMP)
(defun pref-suf (str len)
"Obliczanie tablicy najdluzszych prefikso-sufiksow napisu.
Parametry: str - ciag wejsciowy
           len - dlugosc napisu"
	(do* ((j -1)
		  (p (make-array len :initial-element -1))
		  (i 1 (+ i 1)))
		((<= len i) p)
		(do ()
			((or (< j 0)
				 (equalp (char str i)
						 (char str (+ j 1)))))
			(setf j (svref p j)))
		(if (equalp (char str i) (char str (+ j 1)))
			(setf j (+ j 1)))
		(setf (svref p i) j)))
(defun kmp (str wz)
"Wyszukiwanie wzorca (wz) w tekscie (str)."
	(do* ((i 0 (+ i 1))
		  (j 0)
		  (strlen (length str))
		  (wzlen (length wz))
		  (p (pref-suf wz wzlen))
		  (res nil))
		((<= strlen i) (nreverse res))
		(do ()
			((or (< j 0)
				 (char= (char str i)
						(char wz (+ j 1)))))
			(setf j (svref p j)))
		(if (char= (char str i)
				   (char wz (+ j 1)))
			(setf j (+ j 1)))
		(if (equalp (+ j 1) wzlen)
			(progn
				(push (- i j) res)
				(setf j (svref p j))))))

;;; Wyciąganie numeru telefonu ze stringa
(defmacro strconcat (str x)
	`(setf ,str (concatenate 'string ,str ,x)))

(defun get-telnum (str)
	(let ((out nil))
		(dolist (res (kmp str "+48-"))
			(strconcat out "|")
			(strconcat out (subseq str res
					(position-if #'(lambda(x) (not (or (digit-char-p x) (char= x #\-))))
								 str :start (+ 1 res)))))
		(if out (subseq out 1 ))))

;;; Główna funkcja
(defun main (datafile)
	(with-open-file (infile datafile)
		(let ((dane_we_data (tokens (read-line infile nil) (constituent #\ ))))
			(print-header (fourth dane_we_data) (subseq (fifth dane_we_data) 0 8)))
		(read-line infile nil) ; Pomija linię opisową
		(do	((in (read-line infile nil) (read-line infile nil))
			 (dt '(1990 01 22)))
			((null in))
			(setf in (tokens in (constituent #\;)))
			(setf dt (tokens (ninth in) (constituent #\-)))
			(addn (make-node
						:id (subseq (second in) 0 8)
						:imie (let ((desc (tokens (fourth in) (constituent #\ ))))
							(format nil "~A ~A" (unpolish (first desc)) (unpolish (second desc))))
						:mail (unmail (first (last (tokens (fourth in) (constituent #\ )))))
						:obrwl (num (substitute #\. #\, (fifth in)))
						:obrgr (num (substitute #\. #\,  (sixth in)))
						:pro (num (seventh in))
						:wst (num (ninth in))
						:nieakt (string= (tenth in) "1")
						:parid (subseq (third in) 0 8)
						:days (days-since (num (third dt)) (num (second dt)) (num (first dt)) curr-d curr-m curr-y)
						:tel (get-telnum (fourth in)))
				  curr)
		)
		(dfs root)
		(print-tree root)
		(format t "~2%}~%")))

(main +drzewo-filename+)

(defun profiles ()
	(sb-profile:profile	main leap? month->num year-days year->num date->num days-since unpolish unmail constituent tokens addn dfs print-header pref-suf kmp get-telnum main))
(defun watch ()
	(sb-profile:unprofile)
	(sb-profile:reset)
	(profiles)
	(main +drzewo-filename+)
	(sb-profile:report)
	(sb-profile:unprofile))