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

;; Bobp, 10/86

;; grid-locs for iop

;; 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 nil)

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

;; 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 nil)

;; 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
  n-pins
  programmable-p
  socket)   ;disembodied property list for :programmable-p, :socket-p, :fancy-socket-p

;; 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 (redac-parse-iop) and (telesys-parse-iop)
;; save most recent values here
(defvar iop-net)
(defvar iop-locs)

;; set by (process-k-wire-list) and (process-iop-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-k-wire-list p-net m-net p-locs m-locs))

(defvar redac-iop-file "angel://lmi//bobp//iop//LMI_NET.LST")

(defun redac-parse-iop ()
  (multiple-value-setq (iop-locs iop-net)
    (redac-parse-file redac-iop-file ""))
  (process-iop-wire-list iop-net iop-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
    (wintern (string-append prefix (redac-get-field l 0 5)))
    (wintern (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
    (wintern (string-append pfx (redac-get-field l 0 14)))	;name
    (make-conn					                ;conn
      :chip-loc
        (wintern (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
        (wintern (redac-get-field l 35 40))
      :chip-type
        (wintern (redac-get-field l 45 58))
      :path
        (wintern (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-k-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
      (wintern (string-append prefix (substring l (1+ semi))))
      (wintern (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 (wintern (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 (wintern (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 net)
  (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 (wintern 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
			      (wintern (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)
	and collect 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 (eq pt 'pin-conn) into pin-conn
	count (member pt random-pin-types) into pin-foo
	finally
	(cond
	  ((and (zerop pin-foo)
		(or (> pin-out 2)
		    (and (plusp pin-out)
			 (not (zerop pin-bi)))))
	   (return "Multiple outputs driving"))
	  ((plusp pin-conn)
	   (return nil))
	  ((or (zerop (+ pin-in pin-bi pin-foo supply))
	       (<= (length (cadr node)) 1))
	   (return "No inputs using"))
	  ((and (zerop pin-foo)
		(zerop pin-out)
		(zerop pin-bi))
	   (return "No outputs driving"))
	  )))

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

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

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

;; 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")
(defconst iop-pals "angel://lmi//bobp//iop//*.pal")

;; 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
	(format t "~&~s" (send f :string-for-printing))
	(let ((pal (parse-pal-file f)))
	  (let ((p (assoc (pal-name pal) pal-database)))
	    (if p
		(setf (cdr p) (cdr pal))
	      (push pal pal-database))))))

(defun parse-pal-file (f)
  (with-open-file (s f)
    (parse-pal s)))

;; 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 fix-pals (wl)
  (fix-pal-pins
    (wl-locations wl)
    (wl-net wl)))

(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)))
    
    ;;up to next blank line is comment
    (setf (pal-comment pal)
	  (apply 'string-append
		 (loop for l = (read-pal-record s)
		       until (string= "" l)
		       append (list l " "))))
    ;;pal name is first field of second line
    (setf (pal-name pal) (read-from-string (pal-comment pal)))
    
    (let* ((out-lines (loop for l = (read-pal-record s)
			    until (string= "" l)
			    append
			    (list l " ")))
	   (pin-names (parse-pal-pin-names (apply 'string-append out-lines)))
	   (out-list (parse-output-pins-from-equations s)))	;read equations
      (loop for (pin-num pin-name) in pin-names	                ;make pin-types list
	    (let ((pin-type (cadr (assoc pin-name out-list))))
	      (push
		(list pin-num (or pin-type 'pin-in))
		(pal-pin-types pal)))))
    pal))

(defun read-pal-record (s)
  (let ((l (read-record s nil)))
    (when l
      (string-trim '(#\space #\tab) (substring l 0 (string-search-char #\; l))))))

;; make a list of (pin-name pin-type) for output pins
(defun parse-output-pins-from-equations (s)
  (loop for l = (read-pal-record s)
	while l
	when (string-search-char #\= l)
	collect (parse-pal-equation l)))

;; return list of pin-name and pin-type
(defun parse-pal-equation (l &aux (pin-type 'pin-out))
  (setq l (substring l 0 (string-search-char #\= l)))
  (cond
    ((and (string= "IF" l :end2 2)
	  (string-search-char #\( l))
     (let ((cnd (string-trim '(#\space #\( #\) #\/ #\:)
			     (substring l
					(string-search-char #\( l)
					(string-search-char #\) l)))))
       (unless (string= cnd "VCC")
	 (setq pin-type 'pin-bi))))
    ((string-search-char #\: l)
     (setq pin-type 'pin-bi)))
  (setq l (substring l (or (string-search-char #\) l) 0)))
  (list
    (wintern (string-trim '(#\space #\) #\/ #\: #\=) l))
    pin-type))

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

(defun make-row-locs (st-row end-row first-row row-inc pfx)
  (loop for row from st-row to end-row
	for i from first-row by row-inc
	collect (list
		  (wintern (format nil "~a~c" pfx row))
		  i)))
		  
(defconst 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)))

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

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

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

(defun make-iop-loc-grid ()
  (setq grid-locs
	(append
	  ;; A1 .. J33
	  (make-grid (make-row-locs #\A #\J 14 14 "") 1 33)

	  ;; C25 .. C200, C300 .. C310, C025 .. C099
	  (make-simple 'C0 25 99 nil nil)
	  (make-simple 'C 25 99 nil nil)
	  (make-simple 'C 100 200 nil nil)
	  (make-simple 'C 300 310 nil nil)

	  ;; JP1 .. JP70
	  (make-simple 'JP 1 70 nil nil)

	  (make-simple 'R0 1 9 nil nil)
	  (make-simple 'R 10 15 nil nil)
	  (make-simple 'R 50 65 nil nil)

	  ;; CY1
	  (make-simple 'CY 1 1 nil nil)

	  ;; P1A P1B P1C P2A P2B P2C P3A P3B P3C
	  (make-din-connector 'p1 0 125)
	  (make-din-connector 'p2 0 75)
	  (make-din-connector 'p3 0 25)

	  ;; P4 P5 P6 P7 P8 P9 P10
	  `(,(make-loc 'p4 150 20)
	    ,(make-loc 'p5 150 35)
	    ,(make-loc 'p6 150 50)
	    ,(make-loc 'p7 150 90)
	    ,(make-loc 'p8 150 140)
	    ,(make-loc 'p9 135 80)
	    ,(make-loc 'p10 135 105))

	  ;; S02 S03 S04 S05 S06 S07 S08 S09
	  (make-simple 's0 2 9 nil nil)
	  ;; S1 S10 S11 S12 S13 S14
	  (make-simple 's 1 1 nil nil)
	  (make-simple 's 10 14 nil nil)

	  ;; SIM1 SIM2 SIM3 SIM4
	  (make-simple 'sim 1 4 70 90)
	  `(,(make-loc 'simr nil nil))

	  ;; SW1 SW2
	  (make-simple 'sw 1 2 150 120)

	  ;; CR01 .. CR03
	  (make-simple 'cr0 1 3 nil nil)

	  (make-simple 'fet 1 1 nil nil)
	  (make-simple 'led 0 0 150 112)
	  )))

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

(defun make-loc (name x y)
  `(,(wintern 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
				(fix (* (1- col) 4.5))))))

(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-din-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 (net)
  (loop for node in net
	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 net)
  (uniq
    (sort
      (loop for node in net
	    append
	    (loop for conn in (cadr node)
		  when (eq loc (conn-chip-loc conn))
		  collect (car node)))
      'string-lessp)
    'equal))

;; 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

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

(defconst iop-bus-list '(a backsw bvam d db fbad fbda hdb ia id
			   mad madr md pd qa sd sdbi sdbo so
			   va vadr vam vd virq vmeint))

(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 = (wintern (alpha-part (car node)))
	  for ex = (assoc base-name ex-list)
	  when ex
	  (push (list (car node) len) (cdr ex)))
    (let ((bus-out
	    (sortcar
	      (loop for ex in ex-list
		    collect
		    (let ((lens (sortcar (cdr ex) 'hairy-lessp)))
		      (loop for (name len) in lens
			    minimize len into min
			    maximize len into max
			    finally (return (list
					      max
					      min
					      (car (first lens))
					      (caar (last lens)))))))
	      '>)))
      (loop for (max min first last) in bus-out
	    (format t "~&max=~4,1,-1f\" min=~4,1,-1f\": ~a..~a"
		    max
		    min
		    first
		    last)))))

(defun exclude-p (name list)
  (memq (wintern (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-k-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-wl
    :net net
    :lengths lengths
    :locations locs
    :net-by-loc loc-list))

;; given the wirelists for the iop board,
;;   do the top-level processing stuff
;;   return node-net list
(defun process-iop-wire-list (iop-net iop-locs)
  (format t "~&processing locations:")
  (setq locs (process-locations iop-locs nil))
  
  (format t "~&processing net-list:")
  (setq net (process-net-list locs iop-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-wl
    :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 (wintern (string-append "P_" (symbol-name q))))
	      (q (wintern (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))))

(defun fix-pins (wl)
  (fix-pin-types
    (wl-locations wl)
    (wl-net wl)))

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

(defconst out-that-should-be-bi '(74ALS534 |27512|))
(defconst bi-that-should-be-in '(RED_LED))
(defconst in-that-should-be-bi nil)
(defconst resistors '(res_10 res_220 res_330 rs10_1k rs8_220_330 res_10k res_1k cap_0.1uf))
(defconst connectors '(con50 din96 conn96 db25f
		       jumper_no jumper_3p jumper_nc))

;; 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 connectors)
       (setf (conn-pin-type conn)
	     'pin-conn))
      ((member chip-type resistors)
       (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))
      ((and (member chip-type '(|68010| |AM7990|))
	    (or (string= "A" (alpha-part (conn-pin-name conn)))
		(string= "R_W~" (conn-pin-name conn))))
       (setf (conn-pin-type conn) 'pin-bi))
      ((and (eq chip-type '|74LS693|)
	    (member (conn-pin-name conn) '(QA QB QC QD)))
       (setf (conn-pin-type conn) 'pin-bi))
      ((and (eq chip-type '|MB87030|)
	    (or (string= "SDBO" (alpha-part (conn-pin-name conn)))))
       (setf (conn-pin-type conn) 'pin-out))
      )))

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

;; 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 count-chip-pins (chip)
  (let ((n-pins (loop for pin in (chip-pins chip)
		      when (numberp (pin-number pin))
		        maximize (pin-number pin) into np
		      else
		        count t into bad
		      finally (return (if (plusp bad)
					  (list (length (chip-pins chip)))
					np)))))
    n-pins))

;(putprop (locf (chip-plist (car chip-database))) t :programmable-p)


(defun print-chip-database ()
  (loop for chip in chip-database
	(format t "~2&~a: ~d pins; socket: ~a, prog: ~a"
		(chip-type chip)
		(chip-n-pins chip)
		(chip-socket chip)
		(chip-programmable-p chip))
	(loop for pin in (chip-pins chip)
	      (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))))

(defconst num-set "0123456789")

;; same as string-lessp, except that if non-numeric characters all match,
;; numeric character substring is compared in numeric instead of string order.
(defun hairy-lessp (p1 p2)
  (let ((n1 (string-search-set num-set p1))
	(n2 (string-search-set num-set p2))
	(r1 (string-reverse-search-set num-set p1))
	(r2 (string-reverse-search-set num-set p2)))
    (cond
      ((and n1
	    (eq n1 n2)
	    (string= p1 p2 :end1 n1 :end2 n2)
	    (string= p1 p2 :start1 (1+ r1) :start2 (1+ r2)))
       (< (read-from-string (substring p1 n1 (1+ r1)))
	  (read-from-string (substring p2 n2 (1+ r2)))))
      (t
       (string-lessp p1 p2)))))

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

(defun wintern (str)
  (intern (string-trim '(#\space #\tab) (string-upcase str)) 'user))

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

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

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

(defun find-bad-conns (net)
  (uniq
    (loop for node in net
	  append
	  (loop for conn in (cadr node)
		when (or (null (conn-pin-type conn))
			 (null (conn-pin-name conn)))
		collect node))
    'equal))


(defconst k-pal-locs '((P_F18 CH1_00) (P_F17 CH2_00) (P_F16 CH3_00) (P_H17 CLOCK00)
		       (M_J16 FDEST100) (M_J17 FDEST200) (P_F23 FDEST300) (M_J18 FMSRC00)
		       (P_L11 ICCE00) (P_K11 ICSEQ00) (P_K13 ICWE00) (M_C1 MCAS00)
		       (M_H11 MCHK00) (M_A1 MRAS00) (M_B1 MRAS00) (M_C30 PAT0000)
		       (M_C28 NUERR00) (M_C29 NUMAS00) (M_E33 NUMR00) (M_E31 NUSLV100)
		       (M_E32 NUSLV200) (M_G11 PARITY00) (P_K4 PCINC00) (P_K3 PCINC00)
		       (P_K2 PCINC00) (P_K1 PCINC00) (P_H10 PCMUX00) (M_G10 PREQ00)
		       (P_E10 REGS00) (M_G33 SPY00) (M_C23 STAT00) (M_I15 TRAP00)
		       (M_G9 TRAPMD00)))

(defconst iop-pal-locs '((a11 vmecon)		;16r4a
			 (a14 intreg)		;22v10
			 (b27 vmereqarb)	;22v10
			 (b26 wbyte)		;16l8a
			 (c17 vmedec)		;20l8a
			 (c14 slvdec)		;20r8a
			 (c25 vbufctl)		;2048a
			 (e6 dmactr)		;16r6a
			 (f9 busctl0)		;22v10
			 (f8 busctl1)		;16r4a
			 (f7 busctl2)		;16l8a
			 (f6 busctl3)		;20r8a
			 (f5 busctl4)		;20r8a
			 (b2 scsictl0)		;16r8b
			 (b4 scsictl1)		;20l8a
			 (a6 scsictl2)		;20l8a
			 (h29 busarb)		;16l8a
			 (f26 intcon)		;20l8a (no file)
			 (d30 dtcon)		;16r4a
			 (f28 decode)		;20l8a
			 (d23 rfckpal)		;20x10a
			 (d22 dramcon)		;16r4a, dram
			 (d21 dcon2)		;16l8a (no file)
			 (f11 fbctl0)		;16r4b, frame buffer
			 (i14 fbctl1)		;16r8b
			 (g11 fbctl2)		;16r8b
			 (j8 syncgen)		;16r8a
			 ))

;(defun find-pals ()
;  (loop for q in (wl-locations iop)
;	when (memq (cadr q) p)
;	collect q)) 

(defun find-possible-pal (chip)
  (loop for pal in pal-database
	when (or (string= chip (pal-type pal))
		 (string= chip (substring (pal-type pal) 3)))
	collect pal))

(defun match-pals (wl)
  (loop for (loc chip-type) in (wl-locations wl)
	for pals = (find-possible-pal chip-type)
	when pals
	count t into n
	and collect (list loc pals)
	and do
	(format t "~&~a: ~a:" loc chip-type)
	(loop for (xloc xchip-type) in (wl-locations wl)
	      when (and (eq chip-type xchip-type)
			(neq loc xloc))
	      (format t " ~a" xloc))
	(loop for pal in pals
	      (format t "~&~4t~10a ~a" (pal-name pal) (pal-comment pal)))
	finally
	(format t "~&matched ~d locs" n)
	))

(defmacro ignore-output (body)
  `(let (r)
     (with-output-to-string (*standard-output*)
       (setq r ,body))
     r))

(defmacro ignore-return (body)
  `(progn
     ,body
     nil))

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

;; given random list of q's, return an alist of one of
;; each q and the number of occurences of it.
;; (a "parts-list")
(defun count-elts (l &optional (pred 'string-lessp))
  (let ((elts (sort (copylist l) pred)))
    (let ((counts (loop for q in (uniq elts)
			collect (list q 0))))
      (loop for q in elts
	    (incf (cadr (assoc q counts))))
      counts)))

; returns parts-list alist for a net
(defun count-chips (wl)
  (combine-parts-lists (mapcar 'cdr (wl-locations wl))))
;;  (count-elts (mapcar 'cadr (wl-locations wl))))

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

;(n spare): if more than n, get spare spares
(defconst spare-list '((60 100) (45 75) (20 50) (10 25) (5 20) (1 15)))

(defun spares-func (n)
  (or (cadr (ass '>= n spare-list)) 0))

(defun order-func (n)
  (* 25 (floor (+ n 24) 25)))

;; (print-order-list (make-status-list parts-list inven-list 5 ))
;; (print-order-list (make-status-list parts-list inven-list 15 5 ))

;; given a parts-list, an inventory-list ("parts-list" for current stock),
;;   and a number of boards to make,
;;   show what we have and what we need.
;; returns list of (chip-type n-each n-required what-we-have what-to-order)
(defun make-status-list (parts-list inven-list n-boards &optional (deduct 0))
  (format t "~2&To build ~d set~:p" n-boards)
  (when (plusp deduct)
    (format t " beyond first ~d" deduct))
  (loop for (chip n-each) in parts-list
	collect
	(let* ((req (+ (* n-each n-boards) (spares-func n-each)))
	       (have (max 0 (- (or (cadr (assoc chip inven-list)) 0) (* deduct n-each))))
	       (need (max 0 (- req have))))
	  (list
	    chip
	    n-each
	    req
	    have
	    (order-func need)))))

(defun print-status-list (status-list)
  (format t "~2&Part-number       /Board    Req.    Have   Order")
  (format t  "~&===========       ======    ====    ====   =====")
  (loop for (chip each req have order) in status-list
	(format t "~&~16a~8d~8d~8d~8d"
		chip
		each
		req
		have
		(if (plusp order) order ""))))

;; given a status-list,
;; print an "order" for the parts that are deficient
(defun print-order-list (status-list)
  (format t "~2&Part-number     Count")
  (format t  "~&===========     =====")
  (loop for (chip each req have order) in status-list
	(when (plusp order)
	  (format t "~&~16a~d" chip order))))

(defun print-parts-list (parts-list)
  (format t "~2&Part-number     Count")
  (format t  "~&===========     =====")
  (loop for (chip count) in parts-list
	(format t "~&~16a~d" chip count)))

(defun total-of-parts (parts-list)
  (loop for (chip count) in parts-list
	sum count))

(defun combine-parts-lists (&rest parts-lists)
  (loop for chip-type in (uniq (sort (mapcar 'car (apply 'append parts-lists)) 'string-lessp))
	collect (list
		  chip-type
		  (loop for (part count) in (apply 'append parts-lists)
			when (eq part chip-type)
			sum (or count 1)))))

(defun multiply-parts-list (parts-list n)
  (loop for (part count) in parts-list
	collect (list part (* count n))))

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

;; (print-parts-list (machined-socket-hack parts-list)
;; (print-parts-list (normal-socket-hack parts-list))

;; all machined for first board,
;; just programmable parts for next four
(defun machined-socket-hack (parts-list)
  (combine-parts-lists
    (make-socket-list parts-list)
    (multiply-parts-list
      (make-socket-list parts-list :machined)
      4)))

(defun normal-socket-hack (parts-list)    
  (multiply-parts-list
    (make-socket-list parts-list :default)
    4))
    
(defun make-socket-list (parts-list &optional socket-type)
  (combine-parts-lists
    (loop for (chip-type count) in parts-list
	  for chip = (assoc chip-type chip-database)
	  when (if socket-type
		   (eq (chip-socket chip) socket-type)
		 (chip-socket chip))
	  collect (list (chip-n-pins chip) count))))

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