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

;; Bobp 7/15/86

; Load this file and then type <super>-P to get the menu.
; The menu acts on the currently selected editor buffer, so select
; the board chip-list when you type it.

; The chip database is a list of lists describing chips:
;  ((chip-type max-power typ-power pins area description) ...)

; The input format is a list of lists of chip quantity and chip type:
;  ((quantity chip-type) ...)

; Max-power, typ-power and pins must have numeric values.
; Area may be nil (or unspecified), in which case the area is taken
; to be the area of a standard .300 DIP for the given number of pins.
; Description may be nil.

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

(defstruct (chip (:type :list)
		 :conc-name
		 :size-symbol)
  name
  max-power
  typ-power
  pins
  area
  (description "")
  tens
  hundreds
  thousands
  (availability ""))

(defvar data-file "drac://usr//bobp//chip-database")
(defvar output-file "ed-buffer:power-out")

(defvar pin-array (make-array 200)) ;;chip totals indexed by pin count

(defun default-chip-area (x)
  (or (chip-area x)
      (and (chip-pins x) (calc-area (chip-pins x)))))

;default area based on pin count of .300 DIP
(defun calc-area (pins)
  (if (<= pins 24)
      (* .4 (+ .2 (// pins 20.0)))))

(defun power-menu ()
  (do-forever
    (let ((fun (tv:menu-choose
		 (list
		   `("read database" ,#'read-database)
		   `("write database" ,#'write-database)
		   `("edit database" ,#'edit-database)
		   `("enter new chip" ,#'enter-new-chip)
		   `("delete chip" ,#'delete-chip)
		   `("compute and print results" ,#'compute)
		   `("compute and print into file" ,#'compute-into-file)
		   `("print database" ,#'print-database)
		   `("print database into file" ,#'print-database-into-file)
		   `("set database file name" ,#'set-data-file)
		   `("set output file name" ,#'set-output-file)
		   '("exit" nil)
		   )
		 "Choose function:")))
      (if (null fun)
	  (return nil))
      (funcall fun))))

(zwei:defcom zwei:com-power-menu
	"Menu for chip database and power // area computation"
  ()
  (power-menu)
  zwei:dis-none)

(zwei:command-store 'zwei:com-power-menu #/s-P zwei:*standard-comtab*)

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

;; menu command functions

(defun edit-database ()
  ;;read database from file, if not present
  (if (null chip-database)
      (read-database))
  
  (let* ((chip-choose-list (loop for l in chip-database
				 collect (list (car l) l)))
	 (chip (tv:menu-choose chip-choose-list "Choose chip to edit:")))
    (when chip
      (tv:choose-variable-values (make-chip-edit-list chip)
				 :label "Edit parameters for chip")
      (check-chip chip))
    ))

(defun enter-new-chip ()
  (let ((new-chip (make-chip)))
    (tv:choose-variable-values (make-chip-edit-list new-chip)
			       :label "Enter parameters for new chip")
    (when new-chip
      (check-chip new-chip)
      (let ((old-chip (find-chip (chip-name new-chip))))
	(cond
	  (old-chip
	   (format t "~&Not entering new definition for ~s: one already exists."
		   (chip-name new-chip))
	   (tyi))
	  (t
	   (push new-chip chip-database)
	   (sort-chip-database)))
	))))

(defun delete-chip ()
  (let* ((chip-choose-list (loop for l in chip-database
				 collect (list (car l) l)))
	 (chip (tv:menu-choose chip-choose-list "Choose chip to delete:")))
    (when chip
      (setq chip-database (delq chip chip-database)))))

(defun read-database ()
  (let ((*read-base* 10.)
	(*print-base* 10.)
	(*package* (find-package "USER"))
	(*readtable* (si:find-readtable-named "ZL")))
    (with-open-file (s data-file)
      (setq chip-database (read s))))
  (dolist (l chip-database)
    (check-chip l))
  (sort-chip-database))

(defun write-database ()
  (dolist (l chip-database)
    (check-chip l))
  (sort-chip-database)
  (let ((*read-base* 10.)
	(*print-base* 10.)
	(*package* (find-package "USER"))
	(*readtable* (si:find-readtable-named "ZL")))
    (with-open-file (s data-file :direction :output)
      (format s "~&;-*- Mode:Text -*-~2&;Chip database~2&(")
      (dolist (l chip-database)
	(format s "~& ~s" l))
      (format s "~&)~&")
      )))

(defun print-database-into-file ()
  (with-open-file (*standard-output* output-file :direction :output)
    (print-database)))

(defconst database-header-string
 "Device        Max  Typ Pin  Area    10's   100's  1000's     Avail  Description")
; xxxxxxxxxxxx-xxxx-xxxx-xxx--xxxx-xxxxxxx-xxxxxxx-xxxxxxx-xxxxxxxxx--x
(defconst database-separator-string
 "============  ===  === ===  ====  ======  ======  ======  ========  ===========")
; 74ALS646      190  130  24  0.52 $120.20 $120.20 $120.20      6/86  "Octal bidir reg xcvr"

(defun print-database (&aux (i 0))
  (dolist (l chip-database)
    (check-chip l))
  (format t "~&Chip Database -- ~\datime\")
  (format t "~&~s" data-file)
  (format t "~&~d entries" (length chip-database))

  (format t "~2&~a~&~a" database-header-string database-separator-string)
  ;;(format t "~&~1,1,V,Va" (length database-header-string) #/= "")
  (dolist (chip chip-database)
    (format t "~&~13a~4d ~4d ~3d  ~4,2f ~,,7$ ~,,7$ ~,,7$ ~9@a  ~a"
	    (chip-name chip)
	    (chip-max-power chip)
	    (chip-typ-power chip)
	    (chip-pins chip)
	    (chip-area chip)
	    (or (chip-tens chip) "-")
	    (or (chip-hundreds chip) "-")
	    (or (chip-thousands chip) "-")
	    (or (chip-availability chip) "")
	    (or (chip-description chip) ""))
    (if (= 0 (mod (incf i) 4))
	(format t "~2&"))
    ))

(defun compute ()
  (compute-from-list (read-from-buffer))
  (tyi))

(defun compute-into-file ()
  (let ((chip-list (read-from-buffer)))
    (when chip-list
      (with-open-file (*standard-output* output-file :direction :output)
	(compute-from-list chip-list)))
    ))

(defun read-from-buffer ()
  (multiple-value-bind (chip-list error-p)
      (ignore-errors (read (zwei:interval-stream zwei:*interval*)))
    (cond
      (error-p
       (format t "~&Error in chip list")
       nil)
      (t
       chip-list))))

(defun set-output-file ()
  (tv:choose-variable-values '((output-file "Output File" :string))
			     :label "Set file name:"))

(defun set-data-file ()
  (tv:choose-variable-values '((data-file "Database File" :string))
			     :label "Set file name:"))

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

(defun find-chip (name)
  (ass #'string-equal name chip-database))

;(defun sort-chip-database ()
;  (setq chip-database (sortcar chip-database #'string-lessp)))

(defun sort-chip-database ()
  (setq chip-database (sortcar chip-database #'numbers-in-string-lessp)))

(defun chip-name-lessp (x y &aux x-n1 y-n1)
  ;;use indices into single copy of each string
  ;;extract first numeric substring
  (setq x-n1 (string-search-set digits x)
	y-n1 (string-search-set digits y))
  (cond
    ((and x-n1 y-n1)
     ;;set indices past it
     ;;compare with string-compare, return t or nil if not same
     ;;extract second numeric substring
     ;;if both have it, parse-integer and compare with <, return t or nil if not same
     ;;return string-lessp
     )
    (t
     (string-lessp x y)))
  )

;sort first by first numeric substring in dictionary order,
; second by second numeric substring in numerical order (ignore if either lacks it),
; last by whole string
(defun numbers-in-string-lessp (x y)
  (let ((x-n (chip-sub-nums x))
	(y-n (chip-sub-nums y)))
    (cond
      ((and (car x-n) (car y-n))
       (if (or (not (= (car x-n) (car y-n)))
	       (not (and (cadr x-n) (cadr y-n))))
	   (if (not (and (cadr x-n) (cadr y-n)))
	       (string-lessp x y)
	     (< (car x-n) (car y-n)))
	 (if (not (= (cadr x-n) (cadr y-n)))
	     (< (cadr x-n) (cadr y-n))
	   (string-lessp x y))))
      (t
       (string-lessp x y)))
    ))

(defconst digits "0123456789")

;break chip name into list of numeric substrings
(defun chip-sub-nums (s)
  (let ((num-list nil))
    (dotimes (i (length s))
      (let ((start (string-search-set "0123456789" s i)))
	(when start
	  (let ((num (substring s start (string-search-not-set digits s start))))
	    (push (parse-integer num) num-list)
	    (setq i (+ start (length num)))))
	))
    (reverse num-list)))

(defun make-chip-edit-list (chip)
  (list
    (list (locf (chip-name chip)) "Device type" :string)
    (list (locf (chip-max-power chip)) "Max power" :number)
    (list (locf (chip-typ-power chip)) "Typ power" :number)
    (list (locf (chip-pins chip)) "Pins" :number)
    (list (locf (chip-area chip)) "Area" :number)
    (list (locf (chip-description chip)) "Description" :string)
    (list (locf (chip-tens chip)) "Cost in 10's" :number)
    (list (locf (chip-hundreds chip)) "Cost in 100's" :number)
    (list (locf (chip-thousands chip)) "Cost in 1000's" :number)
    (list (locf (chip-availability chip)) "Availability info" :string)
    ))

;;;;

(defun check-chip (chip &aux err)
  (setf (cdr (last chip)) (make-list (- chip-size (length chip))))	;pad to required length
  (let ((edit-list (make-chip-edit-list chip)))
    (do-forever
      (cond
	((zerop (length (chip-name chip)))
	 (setq err "Name must be specified"))
	((not (numberp (chip-max-power chip)))
	 (setq err "Max power must be a number"))
	((not (numberp (chip-typ-power chip)))
	 (setq err "Typ power must be a number"))
	((not (numberp (chip-pins chip)))
	 (setq err "Pins must be a number"))
	((and (not (numberp (chip-area chip)))
	      (not (setf (chip-area chip) (default-chip-area chip))))
	 (setq err "Area must be specified"))
	(t
	 (return nil)))
      (tv:choose-variable-values edit-list :label err)
      )))

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

(defun compute-from-list (board-list)
  (array-initialize pin-array 0)
  (let ((n-chips 0)
	(max-power-total 0)
	(typ-power-total 0)
	(power-squared-total 0)
	(area-total 0)
	(chip-list nil)
	(bad nil))
    
    (let ((id (pop board-list)))
      (when (neq (car-safe id) :board)
	(format t "~&First entry must be ~s" '(:board "board name"))
	(return-from compute-from-list nil))
      (format t "~2&~a" (cadr id)))
    
    ;;loop for each chip in the input list
    (dolist (l board-list)
      (let ((n (car l))
	    (chip (find-chip (cadr l))))
	(cond
	  ((null chip)
	   (format t "~s does not have a definition" (cadr l))
	   (setq bad t))
	  (t
	   (incf n-chips n)
	   (incf max-power-total (* n (chip-max-power chip)))
	   (incf typ-power-total (* n (chip-typ-power chip)))
	   (incf power-squared-total
		 (* n (^ (- (chip-max-power chip) (chip-typ-power chip)) 2)))
	   (incf (aref pin-array (chip-pins chip)) n)
	   (incf area-total (* n (default-chip-area chip)))
	   
	   ;;make totals of each chip that is used.
	   (if (ass #'string-equal (cadr l) chip-list)
	       (incf (cadr (ass #'string-equal (cadr l) chip-list)) n)
	     (push (list (cadr l) n) chip-list)))
	  )))
    
    (when (null bad)
      (format t "~2&~6,1,-3f Amp MAX" max-power-total)
      (format t "~&~6,1,-3f Amp TYP" typ-power-total)
      (format t "~&~6,1,-3f Amp RMS" (+ typ-power-total (sqrt power-squared-total)))
      
      (format t "~2&")
      
      ;;print count for each size chip
      (dotimes (i (array-length pin-array))
	(when (not (zerop (aref pin-array i)))
	  (format t "~&~6d ~d-pin" (aref pin-array i) i)))
      (format t "~&   ===~&~6d chips~2&" n-chips)
      
      (format t "~&~6,1f square inches (out of 137 available)" area-total)
      
      ;;print chip totals and power for each chip type
      (setq chip-list (sortcar chip-list #'string-lessp))
      (format t "~2&     n    mA~&   ===   ===~&")
      (dolist (l chip-list)
	(let ((n (cadr l))
	      (chip (ass #'string-equal (car l) chip-database)))
	  (format t "~&~6d~6d  ~a" n (* n (chip-max-power chip)) (car l))
	  ))
      (format t "~2&")
      )))

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