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

;; Bobp, 10/86

;; checks:
;;   plausible combinations of input, output and tri-state pins
;;   plausible number of connections
;;   each pin connects to at most one node

;; compare wirelists:
;;   compare two wirelist by comparing in connection-location order
;;     does not depend on node names

;; to-do:
;;   find duplicate names that aren't XSIG's
;;   finish checking loc-list
;;   check that each pin connects to at most one node
;;   warn that funcs that return node-names lose when name is multiply defined
;; for every node: check that chip-loc and chip-type are consistent

;;  compare wirelists by sorting by connections and comparing

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

(defstruct (wl (:type :list))
  net         ;;net as alist of nodes; ((nodename (conn conn ...)) (nodename ...))
	      ;; ordered by connection location
  lengths     ;;net as (length node) alist; ((length (nodename (conn ...))) (length ...))
              ;; ordered in decreasing length
  locations   ;;alist of (loc chip-type)
              ;; ordered by location
  net-by-loc) ;;net as alist of locs; ((loc (conn node) (conn node) ...) (loc ...))
              ;; ordered by location

;; 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 pal-database)

;; alist of (chip-loc pal-name)
;;  ** typed in by hand **
(defvar pal-locs)

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

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

;; list of chip structs
;; alist of (chip-type pin-struct-list)
(defvar chip-database)

;; chip-type is alist of (chip-type chip-struct)
;;   chip-struct is list of pins
;;   alist of (pin-number pin-name pin-type)
(defstruct (pin (:type :list))
  number
  name
  type)

(defstruct (chip (:type :list))
  type
  pins)   ;list of pin structs

;; set by (redac-parse-k) and (telesys-parse-k)
;; save most recent values here
(defvar p-net)
(defvar p-locs)
(defvar m-net)
(defvar m-locs)

;; set by (process-wire-list)
;; saves most recent values here
(defvar locs)
(defvar net)
(defvar lengths)
(defvar loc-list)

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

; save and restore state in qfasl files

(defvar forms-to-save '(chip-database
			pal-database
			pal-locs
			grid-locs))

(defun save-all (&optional (dir-path "lm:bobp.k;"))
  (loop for q in forms-to-save
	when (and (boundp q)
		  (symeval q))
	(save-symbol-value q dir-path)))

(defun save-symbol-value (q &optional (dir-path "lm:bobp.k;"))
  (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))))

(defun restore-symbol-value (q &optional (dir-path "lm:bobp.k;"))
  (let ((file (string-append dir-path (symbol-name q))))
    (format t "~&~s:" file)
    (load file)))

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

; parse REDAC style ascii wire-list

; sample format of REDAC style wirelist.
;   package location database is ignored

; 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

(defvar redac-proc-file "angel://lmi//khh//falcon//PROC//PROC_BD//LMI_NET.LST")
(defvar redac-mem-file "angel://lmi//khh//falcon//PROC//MEM_BD//LMI_NET.LST")

(defun redac-parse-k ()
  (multiple-value-setq (p-locs p-net)
    (redac-parse-file redac-proc-file "P_"))
  (multiple-value-setq (m-locs m-net)
    (redac-parse-file redac-mem-file "M_"))
  (process-wire-list p-net m-net p-locs m-locs))

;; read a redac wire-list file
;; return values are loc-list and net-list
(defun redac-parse-file (f prefix &aux locs net)
  (with-open-file (s f)
    (setq locs (redac-parse-locs s prefix))
    (setq net (redac-parse-net s prefix))
    (values locs net)))

(defun redac-parse-locs (s prefix)
  (redac-skip-lines s "NONPOLARIZED")
  (read-record s nil)
  (loop for l = (read-record s nil)
	while l
	until (string= l "")
	collect (redac-parse-loc-entry l prefix)))

;; first 5 are loc, next 16 are chip-type, rest is path
;; return list of (loc chip-type)
(defun redac-parse-loc-entry (l prefix)
  (list
    (intern (string-append prefix (redac-get-field l 0 5)))
    (intern (redac-get-field l 5 21))))

(defun redac-parse-net (s prefix)
  (loop for node = (redac-parse-node s prefix)
	until (null node)
	collect node))

(defun redac-parse-node (s pfx &aux node-name)
  (and (redac-skip-lines s "SIGNAL_NAME")
       (let ((node-list
	       (loop for l = (read-record s nil)
		     while l
		     until (string= l "")
		     for (name conn) = (redac-parse-wire l pfx)
		     do (setq node-name name)
		     collect conn)))
	 (format t "~a " node-name)
	 (list
	   node-name
	   node-list))))

(defun redac-skip-lines (s pattern)
  (loop for l = (read-record s nil)
	unless l
	  (return nil)
	when (string= l pattern :end1 (string-length pattern))
	  (return t)))

(defun redac-parse-wire (l pfx)
  (list
    (intern (string-append pfx (redac-get-field l 0 14)))	;name
    (make-conn					                ;conn
      :chip-loc
        (intern (string-append pfx (redac-get-field l 16 20)))
      :pin-number
        (read-from-string (string-trim '(#\( #\)) (redac-get-field l 23 27)))
      :pin-type
        (read-from-string (string-subst-char #\- #\space (redac-get-field l 27 34)))
      :pin-name
        (intern (redac-get-field l 35 40))
      :chip-type
        (intern (redac-get-field l 45 58))
      :path
        (intern (string-subst-char #\- #\/ (redac-get-field l 61) nil)))
    ))

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

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

; parse Telesys style wire-list

(defvar telesys-proc-file "angel://lmi//pace//wirelist//p")
(defvar telesys-mem-file "angel://lmi//pace//wirelist//m")

; $PACKAGE
; (96DIN100)!DIN96;P1C
; (96DIN100)!DIN96;P1B
; $NETS
; AF0; E6.2 E4.3 E5.3 D6.2 ,
;  B10.5 B11.5 B12.5
; AF1; E6.5 E4.4 E5.4 D6.5 ,
;  B10.11 B11.11 B12.11

(defun telesys-parse-k ()
  (multiple-value-setq (p-locs p-net)
    (telesys-parse-file telesys-proc-file "P_"))
  (multiple-value-setq (m-locs m-net)
    (telesys-parse-file telesys-mem-file "M_"))
  (process-wire-list p-net m-net p-locs m-locs))

;; read a telesys wire-list file
;; return values are loc-list and net-list
(defun telesys-parse-file (f prefix)
  (with-open-file (s f)
    (let ((l (read-record s)))
      (unless (string-equal l "$package")
	(ferror nil "expected $package, got ~s" l)))
    (let* ((locs (telesys-parse-locs s prefix))
	   (net (telesys-parse-nets s prefix)))
      (values locs net))))

(defun telesys-parse-locs (s prefix)
  (loop for l = (read-record s nil)
	while l
	until (string-equal l "$nets")
	collect (telesys-parse-loc-entry l prefix)))

;; (pkg-type)!chip-type;loc
;; return list of (loc chip-type)
(defun telesys-parse-loc-entry (l prefix)
  (let ((bang (string-search-char #\! l))
	(semi (string-search-char #\; l)))
    (list
      (intern (string-append prefix (substring l (1+ semi))))
      (intern (substring l (1+ bang) semi)))))
  
(defun telesys-parse-nets (s prefix)
  (loop for l = (read-record s nil)
	while l
	until (string-equal l "$end")
	collect (telesys-parse-net l s prefix)))

(defun telesys-parse-net (l1 s prefix &aux node-name)
  (let ((semi (string-search-char #\; l1)))
    (setq node-name (intern (string-append prefix (substring l1 0 semi))))
    (setq l1 (substring l1 (1+ semi))))
  (let ((net (loop for l = l1 then (read-record s nil)
		   while l
		   for comma = (string-search-char #\, l)
		   append (telesys-parse-net-line (substring l 0 comma) prefix)
		   while comma)))
    (list node-name net)))

(defun telesys-parse-net-line (l prefix)
  (setq l (string-trim '(#\space) l))
  (loop for sp = (string-search-char #\space (string-trim '(#\space) l))
	collect (telesys-to-conn (string-trim '(#\space) (substring l 0 sp)) prefix)
	while sp
	do (setq l (string-trim '(#\space) (substring l (1+ sp))))))

(defun telesys-to-conn (f prefix)
  (let ((dot (string-search-char #\. f)))
    (make-conn
      :chip-loc (intern (string-append prefix (substring f 0 dot)))
      :pin-number (read-from-string (string-trim '(#\( #\)) (substring f (1+ dot)))))))

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

; print from internal format

(defun print-list (net)
  (loop for node in net
	(print-node node)))

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

(defun print-node (node &optional (dont-print-if-huge t))
  (format t "~&~a: ~,1,-1f\"" (car node) (compute-length node))
  (cond
    ((and dont-print-if-huge
	  (> (length (cadr node)) 100))
     (format t "~&~4t~d connections" (length (cadr node))))
    (t
     (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 "~&"))))

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

;; make a list of node names
(defun node-names (net)
  (uniq
    (sort
      (loop for node in net
	    collect (car node))
      'string-lessp)))

;; make a list of node names,
;;   excluding XSIG nodes
;;   and with the board prefix stripped
(defun name-hack (net)
  (uniq
    (sort
      (loop for (name conn) in net
	    for n = (substring name 2)
	    unless (string-equal n "xsig" :end1 4)
	    collect (intern n))
      'string-lessp)))

;; make a list of node-names sorted by reversed-strings
(defun name-rev (net)
  (let ((rl (sortcar
	      (loop for n in (node-names net)
		    collect (list
			      (intern (string-reverse (symbol-name n)))
			      n))
	      'string-lessp)))
    (loop for (rev name) in rl
	  collect name)))

;; make a list of nodes whose count of connections meets a spec
(defun find-by-length (net len &optional (pred '=))
  (loop for node in net
	when (funcall pred (length (cadr node)) len)
	collect node))

;; make a list of nodes with this name
(defun find-nodes (name net)
  (loop for node in net
	when (eq name (car node))
	collect node))

;; make a list of nodes that connect to a chip
(defun find-nodes-for-chip (loc net)
  (loop for node in net
	append
	(loop for conn in (cadr node)
	      when (eq loc (conn-chip-loc conn))
	      collect node)))

;; make a list of nodes whose name contains the string
(defun find-node-substring (s net)
  (loop for node in net
	when (string-search s (car node))
	collect node))

;; make a list of (node connection) for all chip pins
(defun flat-conn-list (net)
  (loop for node in net
	append
	(loop for conn in (cadr node)
	      collect (list node conn))))

;; make a list of all chip locations that are used
(defun all-chips (net)
  (uniq
    (sort
      (loop for node in (flat-conn-list net)
	    collect (conn-chip-loc (cadr node)))
      'string-lessp)))

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

(defun chart-conns (net)
  (loop for (conns num) in (count-conns net)
	(format t "~&~d node~:P with ~d connection~:P" num conns)))

;; make alist of (number-of-connections number-of-nodes-with-this-number)
(defun count-conns (net)
  (sortcar
    (let (ll)
      (loop for (name conn) in net
	    for count = (length conn)
	    for lp = (assoc count ll)
	    when lp (incf (cadr lp))
	    else (push (list count 1) ll))
      ll)
    #'<
    ))

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

;; check wire-list by nodes

(defun check-wire-list (net)
  (loop for node in net
	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 hack-names (net)
  (loop for node in net
	collect (list (intern (substring (symbol-name (car node)) 2))
		      (car 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))))))))

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

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

(defconst local-pals "lm:bobp.k.pals;*.*#>")
(defconst angel-pals "angel://lmi//khh//falcon//PALS//*.SRC")

;; parse all pal equation files in a directory
;; return a list of pal structures
(defun parse-pal-directory (&optional (dir-path angel-pals))
  (loop for (f) in (cdr (fs:directory-list dir-path))
	do
	(with-open-file (s f)
	  (format t "~&~s" (send f :string-for-printing))
	  (let ((pal (parse-pal s)))
	    (let ((p (assoc (pal-name pal) pal-database)))
	      (if p
		  (setf (cdr p) (cdr pal))
		(push pal pal-database)))))))

;; for all connections to pals in the wirelist,
;; set the pin-type to that indicated for the pal equation in the pal database
(defun fix-pal-pins (locs net &optional verbose-p)
  (loop for (name conns) in net
	(loop for conn in conns
	      for (loc pal-name) = (assoc (conn-chip-loc conn) pal-locs)
	      when loc
	      do
	      (let* ((pal (assoc pal-name pal-database))
		     (new-type (cadr (assoc (conn-pin-number conn) (pal-pin-types pal)))))
		(when (and verbose-p
			   (neq (conn-pin-type conn) new-type))
		  (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)
		))))

(defun find-pal (name)
  (loop for pal in pal-database
	when (string-search name (pal-name pal))
	collect pal))

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

; parse PAL pin types from pal files

; 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-record s)))		;pal type is first field of first line
      (setf (pal-type pal) (read-from-string l)))
    
    (let ((l (read-record s)))		;pal name is first field of second line
      (setf (pal-name pal) (read-from-string l)))
    
    (setf (pal-comment pal) (read-record s)) ;comment is third line

    (read-record s)				;discard fourth line
    
    (let* ((l1 (read-record s))		;get pin names from next two lines
	   (l2 (read-record 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-record 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))))))

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

; 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-connector 'p_p5 154 30)
	  (make-connector 'p_p4 154 100)
	  (make-connector 'p_p1 0 110)
	  (make-connector 'm_p5 (- m-row-base 146) 30)
	  (make-connector 'm_p4 (- m-row-base 146) 100)
	  (make-connector '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-connector (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))

;; make an alist of (min-length node)
(defun compute-lengths (net)
  (sortcar
    (loop for node in net
	  collect (list
		    (compute-length node)
		    node))
    '>))

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

(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)))

;; change all conn-chip-loc refs of old to new
(defun change-loc (old new net)
  (loop for (name conns) in net
	(loop for conn in conns
	      when (eq old (conn-chip-loc conn))
	      do
	      (format t "~&~s:" name)
	      (setf (conn-chip-loc conn) new))))

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

;; non-critical bus lines to exclude from long-length output

(defvar bus-list '(p_ir p_mpc p_outreg
		       p_mfi p_mfo p_mfio m_mmfio m_bnu_ad
		       vcc gnd))

(defun print-by-lengths (lengths &optional silent-p (bl bus-list) (min 0) (max 100))
  (setq min (fix (* 10 min))
	max (fix (* 10 max)))
  (loop for (len node) in lengths
	when (and (not (exclude-p (car node) bl))
		  (>= len min)
		  (<= len max))
	do (if silent-p
	       (format t "~&~6,1,-1f\": ~a" len (car node))
	     (print-node node))))

(defun print-busses (lengths &optional (bl bus-list))
  (let ((ex-list (sortcar (mapcar 'list bl)
			  'string-lessp)))
    (loop for (len node) in lengths
	  for base-name = (intern (alpha-part (car node)))
	  for ex = (assoc base-name ex-list)
	  when ex
	  (push len (cdr ex)))
    (loop for ex in ex-list
	  (loop for len in (cdr ex)
		minimize len into min
		maximize len into max
		finally (format t "~&min=~4,1,-1f\" max=~4,1,-1f\": ~a" min max (car ex))))))

(defun exclude-p (name list)
  (memq (intern (alpha-part name)) list))

(defun alpha-part (str)
  (substring str 0 (string-search-set "0123456789" str)))

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

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

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

;; general transformation stuff

;; given the wirelists for the two boards,
;;   do the top-level merge and processing stuff
;;   return node-net list
(defun process-wire-list (p-net m-net p-locs m-locs)
  (format t "~&processing locations:")
  (setq locs (process-locations p-locs m-locs))
  
  (format t "~&  merging wirelists:")
  (setq net (merge-boards p-net m-net))
  
  (format t "~&processing net-list:")
  (setq net (process-net-list locs net))
  
  (format t "~&computing lengths:")
  (setq lengths (compute-lengths net))
  
  (format t "~&creating location-heirarchy net:")
  (setq loc-list (make-loc-list locs net))
  
  (make-wire-list
    :net net
    :lengths lengths
    :locations locs
    :net-by-loc loc-list))

(defun process-locations (p-locs m-locs)
  (uniq
    (sortcar
      (append p-locs m-locs)
      'string-lessp)
    'equal))

(defun process-net-list (locs net)
  (format t "~&    setting pin types from chip-database:")
  (fix-pin-types locs net)
  (format t "~&    updating pal pin-types:")
  (fix-pal-pins locs net)
  (format t "~&    sorting nodes by connection location:")
  (sort-net-by-loc net))

;; splice together both wirelists
;;   join through connectors
;;   concatenate
(defun merge-boards (pnet mnet)
  (merge-boards-by-connectors pnet mnet)
  (splice-nodes (assoc 'p_vcc pnet) (assoc 'm_vcc mnet) 'vcc)
  (splice-nodes (assoc 'p_gnd pnet) (assoc 'm_gnd mnet) 'gnd)
  (append
    (remove-empty-nodes pnet)
    (remove-empty-nodes mnet)))

;; splice a pair of nodes together
;;   add second node's connections to first node
(defun splice-nodes (n1 n2 &optional newname)
  (rplacd (last (cadr n1)) (cadr n2))
  (setf (cadr n2) nil)
  (unless (string-equal (car n1) (car n2) :start1 2 :start2 2)
    (format t "~&splicing ~a and ~a" (car n1) (car n2)))
  (when newname
    (setf (car n1) newname)))

;; delete empty nodes leftover from splices
(defun remove-empty-nodes (net)
  (loop for node in net
	when (cadr node)
	collect node))

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

; 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

;; merge the P and M board wire-lists by splicing together
;;   the nodes on either side of the inter-board connectors
(defun merge-boards-by-connectors (pnet mnet)
  (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-by-locs
	    (make-pin-node-alist pnet p)
	    (make-pin-node-alist mnet q)))))

;; given (pin-number node) alists for two locations,
;;   splice together the nodes for corresponding pins
(defun merge-by-locs (l1 l2)
  (loop for p1 in l1
	for p2 = (assoc (car p1) l2)
	when p2
	(splice-nodes (cadr p1) (cadr p2))))

;; make an alist of (pin-number node) for the connections to a chip
(defun make-pin-node-alist (net loc)
  (sortcar
    (loop for node in net
	  append
	  (loop for conn in (cadr node)
		when (eq loc (conn-chip-loc conn))
		collect (list (conn-pin-number conn)
			      node)))
    'pin-lessp))

;; make an alist of (pin-number node-name) for the connections to a chip
(defun make-pin-nodename-alist (net loc)
  (sortcar
    (loop for node in net
	  append
	  (loop for conn in (cadr node)
		when (eq loc (conn-chip-loc conn))
		collect (list (conn-pin-number conn)
			      (car node))))
    'pin-lessp))

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

; check that each pin connects to at most one node
; make list of (conn node)
; sort by conn-chip-loc and conn-pin-number

;; make location-heirarchy form of net list.
;; make alist of (loc (conn node) (conn node) ...) 
;;   for all connections at each loc.
;; naive method results in list too big to sort.
(defun make-loc-list (locs net)
  (let ((ll (uniq (sortcar
		    (loop for (loc) in locs
			  collect (list loc))
		    'string-lessp)
		  'equal)))
    ;;build node list for each element of ll
    (loop for node in net
	  (loop for conn in (cadr node)
		for loc = (assoc (conn-chip-loc conn) ll)
		when loc
		(push (list conn node) (cdr loc))))
    ;;already sorted by loc,
    ;;now sort each loc by pins
    (loop for l in ll
	  (setf (cdr l) (uniq (sortcar (cdr l) 'conn-lessp)
			      'conn-equal)))
    ll))

;; print errors visible in location-heirarchy net.
(defun check-loc-list (loc-list)
  (loop for l in loc-list
	(loop for (conn node) in (cdr l)
	      and for last-conn = nil then conn
	      and for last-node = nil then node
	      when (eq (conn-pin-number conn)
		       (conn-pin-number last-conn))
	      (format t "~&~a pin=~d: ~a ~a"
		      (car l)
		      (conn-pin-number conn)
		      (car node)
		      (car last-node))
	      )))

(defun print-ll-elt (elt)
  (format t "~&~s:" (car elt))
  (loop for (conn node) in (cdr elt)
	(format t "~&~4tpin ~2d: ~14s  ~s"
		(conn-pin-number conn)
		(car node)
		conn)))

(defun print-loc-list (ll)
  (loop for l in ll
	(format t "~&loc=~a" (car l))
	(loop for (conn node) in (cdr l)
	      (format t "~&~8tpin=~2d ~a" (conn-pin-number conn) (car node)))))

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

;; update pin-name and pin-type attributes of all connections
(defun fix-pin-types (locs net)
  (loop for node in net
	(loop for conn in (cadr node)
	      (unless (conn-chip-type conn)
		(setf (conn-chip-type conn) (cadr (assoc (conn-chip-loc conn) locs))))
	      (set-pin-type conn)
	      (fix-pin-type conn))))

;; set pin types from database if not already set
(defun set-pin-type (conn)
  (let ((chip (assoc (conn-chip-type conn) chip-database)))
    (when chip
      (let ((pin (assoc (conn-pin-number conn) (chip-pins chip))))
	(setf (conn-pin-type conn) (pin-type pin))
	(setf (conn-pin-name conn) (pin-name pin))))))

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

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

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

;; build chip-attribute database from verbose wirelist

(defun make-chip-database (net)
  (setq chip-database nil)
  (loop for node in net
	(loop for conn in (cadr node)
	      (add-chip-pin-info
		(conn-chip-type conn)
		(make-pin
		  :number (conn-pin-number conn)
		  :name (conn-pin-name conn)
		  :type (conn-pin-type conn)))))
  (loop for chip in chip-database
	(setf (chip-pins chip) (sortcar (chip-pins chip) 'pin-lessp)))
  (setq chip-database (sortcar chip-database 'pin-lessp))
  nil)

(defun add-pin-info (chip pin)
  (let ((p (assoc (pin-number pin) (chip-pins chip))))
    (if p
	(setf (cdr p) (cdr pin))
      (push pin (chip-pins chip)))))

(defun add-chip-pin-info (chip-type pin)
  (let ((chip (assoc chip-type chip-database)))
    (unless chip
      (setq chip (make-chip :type chip-type))
      (push chip chip-database))
    (add-pin-info chip pin)))

(defun print-chip-database ()
  (loop for (chip-type pins) in chip-database
	(format t "~2&~a:" chip-type)
	(loop for pin in pins
	      (format t "~&~4t~3d ~6a ~6a"
		      (pin-number pin)
		      (pin-name pin)
		      (pin-type pin)))))

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

;; build chip-location database from existing verbose wirelist
;;   not used anymore: locs are now read from wirelist files
;;
(defun make-loc-database (net &aux locs)
  (loop for node in net
	(loop for conn in (cadr node)
	      do
	      (let ((l (assoc (conn-chip-loc conn) locs)))
		(if l
		    (setf (cadr l) (conn-chip-type conn))
		  (push
		    (list
		      (conn-chip-loc conn)
		      (conn-chip-type conn))
		    locs)))))
  (uniq
    (sortcar locs 'string-lessp)
    'equal))

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

;; create net heirarchy ordered by locations of connections
;;   this makes it possible to compare wirelists strictly
;;   based on nets and connections, completely ignoring the node names.

(defun sort-net-by-loc (net)
  (sort
    (loop for node in net
	  collect (list	
		    (car node)
		    (uniq
		      (sort (copylist (cadr node)) 'conn-lessp)
		      'equal)))
    'conn-list-lessp
    :key 'cadr))

;; compare two lists of connections
;;   return non-nil if first comes before second
(defun conn-list-lessp (cl1 cl2)
  (loop for c1 = cl1 then (cdr c1)
	for c2 = cl2 then (cdr c2)
	unless (or c1 c2)   ;;if both exhausted, they were equal
	  return nil
	unless c1           ;;if c1 exhausted, it precedes
	  return t
	unless c2           ;;if c2 exhausted, it precedes
	  return nil
	unless (conn-equal (car c1) (car c2))	;;if equal, try next elt
	  return (conn-lessp (car c1) (car c2))))

;; compare two lists of connections
;;   return non-nil if they are equal
(defun conn-list-equal (cl1 cl2)
  (loop for c1 = cl1 then (cdr c1)
	for c2 = cl2 then (cdr c2)
	unless (or c1 c2)
	  return t
	unless (and c1 c2)
	  return nil
	always (conn-equal (car cl1) (car cl2))))


;; compare two wire-lists
;;   lists must already be sorted in connection-location order
;;   as prepared by (sort-net-by-loc)
(defun compare-wire-lists (net1 net2)
  (loop for (na1 cl1) = (car net1)
	for (na2 cl2) = (car net2)
	while (and net1 net2)
	when (conn-list-equal cl1 cl2)
	do
	  (pop net1)
	  (pop net2)
	else
	do
	  (let ((lp (conn-list-lessp cl1 cl2)))
	    (cond
	      (lp
	       (format t "~&~16a~16@t~d conns" na1 (length cl1))
	       (pop net1))
	      (t
	       (format t "~&~16@t~16a~d conns" na2 (length cl2))
	       (pop net2)))
	    )))

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

(defun uniq (l &optional (pred 'eq))
  (loop for q in l
	and for last = nil then q
	unless (funcall pred q last)
	collect q))

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

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

(defun conn-lessp (c1 c2)
  (if (eq (conn-chip-loc c1)
	  (conn-chip-loc c2))
      (pin-lessp (conn-pin-number c1)
		 (conn-pin-number c2))
    (string-lessp (conn-chip-loc c1)
		  (conn-chip-loc c2))))

(defun conn-equal (c1 c2)
  (loop for i below 5
	for e1 = c1 then (cdr e1)
	for e2 = c2 then (cdr e2)
	always (equal (car e1) (car e2))))

(defun pin-lessp (p1 p2)
  (if (numberp p1)
      (if (numberp p2)
	  (< p1 p2)
	t)
    (if (numberp p2)
	nil
      (string-lessp p1 p2))))

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

(defun read-record (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p
		    options)
  "like read-line but accepts CR or LF as delimiter"
  (declare (values line eof-flag))
  (declare (ignore recursive-p))
  (multiple-value-bind (string eof-flag delimiter)
      (read-delimited-string '(#.(char-int #\Newline) #.(char-int 13) #.(char-int #\End))
			     stream
			     eof-error-p
			     options)
    (if (and eof-flag (zerop (length string)))
	(values eof-value t)
      (when (and (instancep stream)
		 (operation-handled-p stream :rubout-handler))
	(send stream :tyo delimiter))
      (values string eof-flag))))

;;;;

(defun count-elts (l)
  (loop for q in l
	when (consp q)
	sum (count-elts q)
	else
	sum 1))

(defun invalidate-chip-type (net)
  (loop for node in net
	(loop for conn in (cadr node)
	      (setf (conn-chip-type conn) nil)
	      (setf (conn-pin-type conn) nil)
	      (setf (conn-pin-name conn) nil))))

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

; print all nodes in net order
;   (print-list (wl-net wl))
; print one node
;   (print-node
; print nodes of given name
;   (print-node-name

; make list of nodes of given name
;   (find-nodes
; make list of nodes whose name contains given string
;   (find-node-substring
; make list of nodes whose length matches a spec
;   (find-by-length

; perform input/output connection checks on wire-list
;   (check-wire-list
; compare two wire-lists by comparing in connection-location order
;   (compare-wire-lists

; build pal database from files in directory
;   (parse-pal-directory
; update connection pin types from pal database
;   (fix-pal-pins net
; find pal definition whose name contains given string
;   (find-pal

; print by wire-lengths
;   (print-by-lengths
; print min and max lengths of specified busses
;   (print-busses
; print by number of connections
;   (chart-conns (wl-net wl))

; check for different nodes connecting to same pins
;   (check-loc-list
; print each loc and name of node connecting to each pin
;   (print-loc-list (wl-net-by-loc wl))
; print name of nodes connecting to each pin for a loc of a loc-list element
;   (print-ll-elt

; print chip pin-type database
;   (print-chip-database

(defun check-all (wl)
  (check-wire-list (wl-net wl))
  (check-loc-list (wl-net-by-loc wl)))

(defun print-all (wl)
  (print-by-lengths (wl-lengths wl) nil bus-list 10.0)
  (print-busses (wl-lengths wl))
  (chart-conns (wl-net wl)))

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