;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

;; to-do:
;;   fix P_R and M_R defs
;;   funcs that return node-names lose when name is multiply defined
;; for every node: check that chip-loc and chip-type are consistent

;;;;;;;;;;;;;;;;

;; parse daisy wirelist into list structure

; SIGNAL_NAME   PHYLOC - PIN attrib  NAME   of PART_NM         PATH/PAGE
; AD10            UN69 - 7   pin in  A10    of CY7C171_25      @MEM_BD/NUBUS/7   
; VCC             UA7  - (1) pin bi  B2     of SIP_1K          @PROC_BD/ALU/1   
; VCC             UA29 - B14 supply  VCC    of WTL2264         @PROC_BD/ALU/2   
; 01234567890123456789012345678901234567890123456789012345678901234567890123456789
;           1         2         3         4         5         6         7

; node is (name (connections ...))


;; final merged list of (node-name connection-list)
(defvar wire-list)

;; temporary parsed wire-lists for each board
(defvar proc-wire-list)
(defvar mem-wire-list)

;; structure of each element of connection-list
(defstruct (conn (:type :list))
  chip-loc
  pin-number
  pin-type
  pin-name
  chip-type
  path)

;; list of pal defstructs
(defvar pals)

;; alist of (chip-loc pal-name)
(defvar pal-locs)

;; structure of an element of pals
(defstruct (pal (:type :list))
  name
  type
  comment
  pin-types	;;(pin-number pin-type)
  locations)

;; sorted list of all chip-locations
(defvar all-chips)

;; alist of (chip-loc (x-coord y-coord))
(defvar grid-locs)

;; alist of length and node-name sorted by decreasing length
(defvar lengths)

;;;;

(defvar forms-to-save '(wire-list pals pal-locs grid-locs lengths))

(defun save-all (&optional (dir-path "lm:bobp.k;"))
  (loop for q in forms-to-save
	when (symeval q)
	do (let ((file (string-append dir-path (symbol-name q))))
	     (format t "~&~s:" file)
	     (compiler:fasd-symbol-value file q))))

(defun restore-all (&optional (dir-path "lm:bobp.k;"))
  (loop for q in forms-to-save
	do (let ((file (string-append dir-path (symbol-name q))))
	     (load file))))

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;

; stuff to parse ascii wire-list

(defun parse-wire-list (s)
  (loop for q = (parse-one-node s)
	until (null q)
	collect q))

(defun parse-one-node (s &aux node-name)
  (and (find-next s)
       (let ((node-list
	       (loop for l = (read-line s nil)
		     until (or (null l) (string= l ""))
		     for (name conn) = (parse-wire l)
		     do (setq node-name name)
		     collect conn)))
	 (format t "~a " node-name)
	 (list
	   node-name
	   node-list))))

(defun parse-one-node (s &aux node-name)
  (and (find-next s)
       (let ((node-list
	       (loop for l = (read-line s nil)
		     until (or (null l) (string= l ""))
		     collect (multiple-value-bind (name conn)
				 (parse-wire l)
			       (setq node-name name)
			       conn))))
	 (format t "~a " node-name)
	 (list
	   node-name
	   node-list))))

(defun find-next (s)
  (loop for l = (read-line s nil)
	unless l
	  (return nil)
	when (string= l "SIGNAL_NAME" :end1 11)
	  (return t)))

(defun parse-wire (l)
  (let ((conn (make-conn))
	(name (intern (get-field l 0 14))))	;name
    (setf (conn-chip-loc conn)
	  (intern (get-field l 16 20)))		;phys-loc
    (setf (conn-pin-number conn)
	  (let ((p (read-from-string (get-field l 23 27))))
	    (if (listp p)			;pin-number
		(car p)
	      p)))
    (setf (conn-pin-type conn)
	  (read-from-string (string-subst-char #\- #\space (get-field l 27 34) nil)))	;pin-type
    (setf (conn-pin-name conn)
	  (intern (get-field l 35 40)))		;pin-name
    (setf (conn-chip-type conn)
	  (intern (get-field l 45 58)))		;chip-type
    (setf (conn-path conn)
	  (intern (string-subst-char #\- #\/ (get-field l 61) nil)))	;path
    (list name conn)))

(defun get-field (l from &optional to)
  (string-trim '(#\space) (substring l from to)))

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;

; stuff to print from internal format

(defun print-list (&optional (wl wire-list))
  (loop for node in wl
	(print-node node)))

(defun print-by-lengths (lengths)
  (loop for (len name) in lengths
	(print-node-name name)))

(defun print-node-name (n &optional (wl wire-list))
  (cond
    ((symbolp n)
     (loop for node in (find-nodes n wl)
	   (print-node node)))
    (t
     (print-node n))))

(defun print-node (node)
  (format t "~&~a: ~,1,-1f\"" (car node) (compute-length node))
  (loop for conn in (cadr node)
	(format t "~&~4tpin ~d of ~a at ~a; ~a, ~a, ~a"
		      ;;pin 3 of 74F00 at UN42; input, A10, path
		(conn-pin-number conn)
		(conn-chip-type conn)
		(conn-chip-loc conn)
		(conn-pin-type conn)
		(conn-pin-name conn)
		(conn-path conn))
	(let ((pal-loc (assoc (conn-chip-loc conn) pal-locs)))
	  (when pal-loc
	    (format t " (~s)" (cadr pal-loc))))
	(let ((grid-loc (cadr (assoc (conn-chip-loc conn) grid-locs))))
	  (when grid-loc
	    (format t " (~d,~d)" (car grid-loc) (cadr grid-loc))))
	)
  (format t "~&"))

(defun node-names (&optional (wl wire-list))
  (loop for l in wl
	collect (car l)))

(defun name-hack (&optional (wl wire-list))
  (sort
    (loop for (name conn) in wl
	  for n = (substring name 2)
	  unless (string-equal n "xsig" :end1 4)
	  collect (intern n))
    'string-lessp))

(defun name-rev (l)
  (sortcar
    (loop for x in l
	  collect (list (intern (string-reverse (symbol-name x)))
			x))
    'string-lessp))


(defun find-by-length (wl len &optional (pred '=))
  (loop for l in wl
	when (funcall pred (length (cadr l)) len)
	collect l))

(defun chart-length (&optional (wl wire-list))
  (loop for (conns num) in (count-lengths wl)
	(format t "~&~d node~:P with ~d connection~:P" num conns)))

(defun count-lengths (&optional (wl wire-list))
  (sortcar
    (let (ll)
      (loop for (name conn) in wl
	    for len = (length conn)
	    for lp = (assoc len ll)
	    when lp (incf (cadr lp))
	    else (push (list len 1) ll))
      ll)
    #'<
    ))

(defun find-nodes (nodename &optional (wl wire-list))
  "return a list of nodes with this name"
  (loop for q in wl
	when (eq nodename (car q))
	collect q))

(defun find-node-names-for-chip (chip &optional (wl wire-list))
  (loop for node in wl
	append
	(loop for conn in (cadr node)
	      when (eq chip (conn-chip-loc conn))
	      collect (car node))))

(defun find-nodes-for-chip (chip &optional (wl wire-list))
  (loop for node in wl
	append
	(loop for conn in (cadr node)
	      when (eq chip (conn-chip-loc conn))
	      collect node)))

(defun find-node-substring (s &optional (wl wire-list))
  (loop for (name conn) in wl
	when (string-search s name)
	collect name))

(defun flat-conn-list (&optional (wl wire-list))
  (loop for node in wl
	append
	(loop for conn in (cadr node)
	      collect (list (car node) conn))))

(defun all-chips (&optional (wl wire-list))
  (setq all-chips (uniq-sort
		    (loop for node in (flat-conn-list wl)
			  collect (conn-chip-loc (cadr node))))))

;;;;;;;;;;;;;;;;

(defun find-pin-type (pt &optional (wl wire-list))
  (loop for node in wl
	(loop for w in (cadr node)
	      when (eq (conn-pin-type w) pt)
	      (format t "~&~s" w))))

(defun fix-pin-types (&optional (wl wire-list))
  (dolist (node wl)
    (dolist (conn (cadr node))
      (fix-pin-type conn))))

(defvar out-that-should-be-bi '(74ALS534))
(defvar bi-that-should-be-in '(RED_LED))

(defun fix-pin-type (conn)
  (let ((chip-type (conn-chip-type conn))
	(pin-type (conn-pin-type conn)))
    (cond-every
      ((eq chip-type 'conn96)
       (setf (conn-pin-type conn) 'pin-conn))
      ((eq chip-type 'res_10)
       (setf (conn-pin-type conn) 'pin-res))
      ((and (member chip-type out-that-should-be-bi)
	    (eq pin-type 'pin-out))
       (setf (conn-pin-type conn) 'pin-bi))
      ((and (member chip-type bi-that-should-be-in)
	    (eq pin-type 'pin-bi))
       (setf (conn-pin-type conn) 'pin-in))
      )))

;;;;;;;;;;;;;;;;

(defun check-list (&optional (wl wire-list))
  (loop for node in wl
	for err = (check-node node)
	when err
	do
          (format t "~2&~a " err)
	  (print-node node)))

(defvar random-pin-types '(pin-foo pin-led pin-res))

; error if none of output, bi or tri
; error if output and any of output, bi or tri

(defun check-node (node)
  (loop for w in (cadr node)
	for pt = (conn-pin-type w)
	count (eq pt 'pin-in) into pin-in
	count (eq pt 'pin-out) into pin-out
	count (or (eq pt 'pin-tri) (eq pt 'pin-bi)) into pin-bi
	count (eq pt 'supply) into supply
	count (member pt random-pin-types) into pin-foo
	finally
	(when (or (zerop (+ pin-in pin-bi pin-foo supply))
		  (<= (length (cadr node)) 1))
	  (return "No inputs using"))
	(when (and (zerop pin-foo)
		   (zerop pin-out)
		   (zerop pin-bi))
	  (return "No outputs driving"))
	(when (and (zerop pin-foo)
		   (or (> pin-out 2)
		       (and (plusp pin-out)
			    (not (zerop pin-bi)))))
	  (return "Multiple outputs driving"))))

;;;;;;;;;;;;;;;;

(defun uniq (l)
  (loop for q in l
	and for last = nil then q
	when (neq q last)
	collect q))

(defun uniq-sort (l)
  (uniq (sort (copy-list l) 'string-lessp)))

(defun dup (l &optional (acc #'(lambda (x) x)))
  (loop for q in l
	and for last = nil then q
	when (eq (funcall acc q) (funcall acc last))
	  collect (funcall acc q)))

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;

(defun compare-lists (w1 w2)
  ;;find duplicate signal names in style of merge-sort
  (loop until (or (null w1) (null w2))
	(let ((x (string-compare (caar w1) (caar w2))))
	  (cond
	    ((zerop x)				;w1 = w2
	     (format t "~&~s" (caar w1))
	     (pop w1)
	     (pop w2))
	    ((minusp x)				;w1 < w2
	     (pop w1))
	    (t					;w1 > w2
	     (pop w2))))
	))

(defun hack-names (wl)
  (loop for node in wl
	collect (list (intern (substring (symbol-name (car node)) 2))
		      (car node))))

;;;;;;;;;;;;;;;;

(defun prepend-names (wl prefix)
  (loop for node in wl
	(setf (car node) (intern (string-append prefix (symbol-name (car node)))))))

(defun prepend-locs (wl prefix)
  (loop for (name conn) in (flat-conn-list wl)
	(setf (conn-chip-loc conn)
	      (intern (string-append prefix (symbol-name (conn-chip-loc conn)))))))
	

; splice together a pair of nodes
;   add second node's connections to first node
;   delete second node from list
;   first node retains its name

(defun splice-nodes (n1 n2)
  (rplacd (last (cadr n1)) (cadr n2))
  (setf (cadr n2) nil)
  ;;for now, leave empty n2 in place
  )

(defun flush-empty-nodes (wl)
  (loop for node in wl
	when (cadr node)
	collect node))

; splice together both wirelists
;   find duplicate signal names between wirelists
;   add "p_" or "m_" to start of every chip location (and signal name?)
;   concatenate wirelists
;   splice across connectors

;;;;;;;;;;;;;;;;

; build list of nodes that include connectors p4 and p5
; sort by connector and pin number
; compare node names for each side
; step lists for both boards and splice nodes

(defun make-loc-list (wl loc)
  (sortcar
    (loop for node in wl
	  append
	  (loop for conn in (cadr node)
		when (eq loc (conn-chip-loc conn))
		collect (list (conn-pin-number conn)
			      node)))
    '<))

(defun make-loc-name-list (wl loc)
  (sortcar
    (loop for node in wl
	  append
	  (loop for conn in (cadr node)
		when (eq loc (conn-chip-loc conn))
		collect (list (conn-pin-number conn)
			      (car node))))
    '<))

(defun merge-foo ()
  (loop for q in '(p4a p4b p4c p5a p5b p5c)
	(let ((p (intern (string-append "P_" (symbol-name q))))
	      (q (intern (string-append "M_" (symbol-name q)))))
	  (merge-connectors
	    (make-loc-list proc-wire-list p)
	    (make-loc-list mem-wire-list q)))))

(defun merge-connectors (l1 l2)
  (loop for p1 in l1
	for p2 = (assoc (car p1) l2)
	when p2
	(splice-nodes (cadr p1) (cadr p2))))

;;;;;;;;;;;;;;;;

;; wire-list now has whole wire list;
;; z has (hack-names), that is list of names with prefixes stripped;
;; (dup z) is conflicts.

;; fix conflicts and strip prefixes;
;; then delete conn96 refs from p4, p5 nodes

;; compute max line lengths based on perimeters of min-rectangle for node.

(defun print-connectors (&optional (wire-list wire-list))
 (let ((p "P_P00"))
  (loop for b in '(#\P #\M)
    (loop for i from #\1 to #\5
	(loop for j from #\A to #\C
		(setf (aref p 0) b)
		(setf (aref p 3) i)
		(setf (aref p 4) j)
		(let ((ps (intern p)))
		  (format t "~&~s: ~s" ps (make-loc-name-list wire-list ps))))))))

(defvar wl-ptr nil)

(defun print-inc (wl)
  (loop for ptr on wl
	do
	(print-node (car ptr))
	(setq wl-ptr ptr)))

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;

; parse PAL pin types

; PAL16R4 B                                           PAL DESIGN SPECIFICATION
; CH1_00                                              KENT HOULT  
; CALL HARDWARE CONTROL PAL #1                        9/09/86
; 
; C_PROC IR48 IR49 IR50 /TRAP1 RD5 RD6 /FRDEST /WOAR GND
; /OE /HP_DEC /HP_CNT H_WE /PREV_INC /PREV_DEC NC17 /RF_CE RF_SEL VCC
; 
; IF(VCC) HP_DEC = /TRAP1 * /IR50 * /IR49 *  IR48     ; OPEN
;                +  TRAP1 * PREV_INC

(defun parse-pal (s)
  (let ((pal (make-pal)))
    (let ((l (read-line s)))			;pal type is first field of first line
      (setf (pal-type pal) (read-from-string l)))
    
    (let ((l (read-line s)))			;pal name is first field of second line
      (setf (pal-name pal) (read-from-string l)))
    
    (setf (pal-comment pal) (read-line s))	;comment is third line
    
    (read-line s)				;discard fourth line
    
    (let* ((l1 (read-line s))			;get pin names from next two lines
	   (l2 (read-line s))
	   (pin-names (parse-pal-pin-names (string-append l1 " " l2 " ")))
	   (out-list (parse-output-pins s)))	;read equations

      (loop for (pin-num pin-name) in pin-names	;make pin-types list
	    (push
	      (list pin-num (if (memq pin-name out-list) 'pin-out 'pin-in))
	      (pal-pin-types pal))))
    pal))

;; make a list of output pins
(defun parse-output-pins (s)
  (loop for l = (read-line s nil)
	while l
	when (string-search-char #\= (substring l 0 (string-search-char #\; l)))
	collect (let ((li (substring l 0 (string-search-char #\= l))))
		  (setq li (substring li (or (string-search-char #\) li) 0)))
		  (intern (string-trim '(#\space #\) #\/ #\: #\=) li)))))

;; make a list of (pin-number pin-name)
(defun parse-pal-pin-names (line)
  (loop for pin from 1
	for sp = (string-search-char #\space line)
	while sp
	collect (let ((field (string-trim '(#\space #\/) (substring line 0 sp))))
		  (list pin (intern field)))
	do (setq line (string-trim '(#\space) (substring line (1+ sp))))))

;;;;;;;;;;;;;;;;

;; make a list of pal locations for each pal name

(defun parse-pal-directory (&optional (dir-path "lm:bobp.k.pals;*.*#>"))
  (setq pals
	(loop for (f) in (cdr (fs:directory-list dir-path))
	      collect (with-open-file (s f)
			(format t "~&~s" (send f :string-for-printing))
			(parse-pal s))))
  (update-pal-locations pals pal-locs)
  nil)

(defun update-pal-locations (&optional (pals pals) (pal-locs pal-locs))
  (loop for (loc name) in pal-locs
	(push loc (pal-locations (assoc name pals)))))

(defun find-pal (name &optional (pals pals))
  (let ((l (loop for pal in pals
		 when (string-search name (pal-name pal))
		 collect pal)))
    (if (= 1 (length l))
	(car l)
      l)))

(defun pals-by-loc (&optional (pals pals))
  (loop for pal in pals
	append
	(loop for loc in (pal-locations pal)
	      collect (list loc pal))))

(defun pal-names-by-loc (&optional (pals pals))
  (loop for pal in pals
	append
	(loop for loc in (pal-locations pal)
	      collect (list loc (pal-name pal)))))

(defun fix-pal-pins (&optional (wl wire-list) (pals pals))
  (let ((pal-locations (pals-by-loc pals)))
    (loop for (name conns) in wl
	  sum
	  (loop for conn in conns
		for (loc pal) = (assoc (conn-chip-loc conn) pal-locations)
		count loc
		when loc
		do
		(let ((new-type (cadr (assoc (conn-pin-number conn) (pal-pin-types pal)))))
;		  (format t "~&~s: changing pin ~d of ~s (~s) at ~s from ~s to ~s"
;			  name (conn-pin-number conn) (pal-name pal) (pal-type pal)
;			  loc (conn-pin-type conn) new-type)
		  (setf (conn-pin-type conn) new-type)
		  )))))

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;

;next:
; wirelist tracer ...
;  pick a signal name
;    display all connections for that node
;    click on a connection to get menu of other signals connected to that chip
;  pick a chip and display all connections

;;;;;;;;;;;;;;;;

;trace-length measurer
;  for each chip location
;    compute a grid position for the boards hinged by the P4-P5 connectors
;  for each node
;    compute the minimum rectangle that contains all points

(defun make-m-rows ()
  (with-output-to-string (*standard-output*)
    (loop for i from 16 by 14
	  for c from #\a to #\j
	  (format t "(m_~c ~d) " c i))))

(defvar p-row-locs '((p_a 16) (p_b 26) (p_c 36) (p_d 46) (p_e 58) (p_f 70) (p_g 84)
		     (p_h 96) (p_i 106) (p_j 120) (p_k 134) (p_l 148)))

(defvar m-row-locs-raw '((m_a 16) (m_b 30) (m_c 44) (m_d 58) (m_e 72) (m_f 86)
			 (m_g 100) (m_h 114) (m_i 128) (m_j 142)))

(defvar m-row-base (+ 154 148))

(defvar m-row-locs (loop for (name x) in m-row-locs-raw
			 collect (list name (- m-row-base x))))

(defun make-loc-grid ()
  (setq grid-locs
	(append
	  ;; P_A1 .. P_L33
	  (make-grid p-row-locs 1 33)
	  
	  ;; M_A1 .. M_J33
	  (make-grid m-row-locs 1 33)
	  
	  ;; M_B27A M_B27B M_B27C M_F16A P_H13A
	  (make-grid-aux (assoc 'm_b m-row-locs) 27 #\A #\C)
	  (make-grid-aux (assoc 'm_f m-row-locs) 16 #\A #\A)
	  (make-grid-aux (assoc 'p_h p-row-locs) 13 #\A #\A)

	  ;; M_SIM0 .. M_SIMF
	  (make-sim 'm_sim 0 15)
	  
	  ;; P_R1, M_R1..M_R6
	  (make-simple 'p_r 1 1 nil nil)
	  (make-simple 'm_r 1 6 nil nil)
	  
	  ;; M_LED1 .. M_LED4
	  (make-simple 'm_led 1 4 (- m-row-base 140) 130)
	  
	  ;; P_P1A..C etc.
	  (make-conn 'p_p5 154 30)
	  (make-conn 'p_p4 154 100)
	  (make-conn 'p_p1 0 110)
	  (make-conn 'm_p5 (- m-row-base 146) 30)
	  (make-conn 'm_p4 (- m-row-base 146) 100)
	  (make-conn 'm_p1 m-row-base 110)
	  ))
  nil)

(defun make-loc (name x y)
  `(,(intern name) (,x ,y)))

(defun make-grid (row-list start-col end-col)
  (loop for (row-name x) in row-list
	append
	(loop for col from start-col to end-col
	      collect (make-loc (format nil "~a~d" row-name col)
				x
				(* (1- col) 4)))))

(defun make-grid-aux (name-x col from-c to-c)
  (loop for c from from-c to to-c
	collect (make-loc (format nil "~a~d~c" (car name-x) col c)
			  (cadr name-x)
			  (* (1- col) 4))))

(defun make-conn (name x y)
  (loop for row from #\A to #\C
	collect (make-loc (format nil "~a~c" name row)
			  x
			  y)))

(defun make-simple (name first last x y)
  (loop for n from first to last
	collect (make-loc (format nil "~a~d" name n)
			  x
			  y)))

(defun make-sim (name first last)
  (loop for sim from first to last
	collect (make-loc (format nil "~a~x" name sim)
			  (- m-row-base 3 (* sim 3))
			  32)))

;;;;;;;;;;;;;;;;

(defun compute-length (node &optional (verbose-p nil))
  (multiple-value-bind (x-min y-min x-max y-max)
      (loop for conn in (cadr node)
	    for (loc (x y)) = (assoc (conn-chip-loc conn) grid-locs)
	    when x
	      minimize x into x-min
	    when y
	      minimize y into y-min
	    when x
	      maximize x into x-max
	    when y
	      maximize y into y-max
	    unless loc
	      (format t "~&~s not defined for ~a" (conn-chip-loc conn) (car node))
	    finally
	      (return (values x-min y-min x-max y-max)))
    (when verbose-p
      (format t "~&~s: x: ~d-~d, y: ~d-~d" (car node) x-min x-max y-min y-max))
    (+ (abs (- x-min x-max))
       (abs (- y-min y-max)))))

(defun len-errs ()
  (loop for node in wire-list
	append (length-error node)))

(defun length-error (node)
  (loop for conn in (cadr node)
	unless (assoc (conn-chip-loc conn) grid-locs)
	collect node))

(defun compute-lengths (&optional (wl wire-list))
  (setq lengths
	(sortcar
	  (loop for node in wl
		collect (list (compute-length node) (car node)))
	  '>))
  nil)

(defun print-len-greater ()
  (loop for i from 0 to 33
	(format t "~&~d longer than ~f" (length (len-compare #'> (* i 10))) i)))

(defun len-compare (func lim)
  (loop for (len name) in lengths
	when (funcall func len lim)
	collect name))

(defun find-by-loc (loc)
  (uniq
    (sort
      (loop for (name conns) in wire-list
	    append
	    (loop for conn in conns
		  when (eq loc (conn-chip-loc conn))
		  collect name))
      'string-lessp)))

(defun find-undef (undef-list)
  (loop for (name conns) in wire-list
	append
	(loop for conn in conns
	      when (memq (conn-chip-loc conn) undef-list)
	      collect name)))

(defun change-loc (old new)
  (loop for (name conns) in wire-list
	(loop for conn in conns
	      when (eq old (conn-chip-loc conn))
	      do
	      (format t "~&~s:" name)
	      (setf (conn-chip-loc conn) new))))