;-------------------------------------------------------------------------
;
;  Drawing transistor stacks for production rules.
;
;  (c) 1996 California Institute of Technology
;  Department of Computer Science
;  Pasadena, CA 91125.
;
;  Permission to use, copy, modify, and distribute this software
;  and its documentation for any purpose and without fee is hereby
;  granted, provided that the above copyright notice appear in all
;  copies. The California Institute of Technology makes no representations
;  about the suitability of this software for any purpose. It is
;  provided "as is" without express or implied warranty. Export of this
;  software outside of the United States of America may require an
;  export license.
;
;  $Id: prs.scm,v 1.1.1.1 2000/03/29 18:35:58 rajit Exp $
;
;-------------------------------------------------------------------------


;------------------------------------------------------------------------------
;
; Production rule parser
; ~~~~~~~~~~~~~~~~~~~~~~
;
;  (prs.parse "production-rule-string")
;
;  Returns a parse tree for the production rule, or prints out an error
;  message.
;
;  A production rule is of the form:  expr -> rhs [+/-]
;  The resulting parse tree has the following format:
;
;     Top level:  (expr "rhs")
;          expr:  (and expr expr)
;                 (or expr expr)
;                 (not id)
;                 id
;
;  Observe that the production rules must be in negation-normal form.
;
;------------------------------------------------------------------------------
(define prs.parse ())

(letrec
    (
     (parse-string "")			; the current string being parsed
     (parse-position 0)			; current position in the string
     (parse-string-len 0)		; string length
     (or-char (string-ref "|" 0))	; constants
     (and-char (string-ref "&" 0))
     (not-char (string-ref "~" 0))
     (plus-char (string-ref "+" 0))
     (minus-char (string-ref "-" 0))
     (lparens-char (string-ref "(" 0))
     (rparens-char (string-ref ")" 0))
     
     (startid?				; #t if the character is a valid
					; start character for an identifier
      (let ((lc-a (string-ref "a" 0))
	    (uc-a (string-ref "A" 0))
	    (lc-z (string-ref "z" 0))
	    (uc-z (string-ref "Z" 0))
	    (us   (string-ref "_" 0))
	    )
	(lambda (x)
	  (cond
	   ((and (>=? x lc-a) (<=? x lc-z)) #t)
	   ((and (>=? x uc-a) (<=? x uc-z)) #t)
	   ((=? x us) #t)
	   (#t #f)
	   )
	  )
	)
      )

     (idchar?				; #t if the character is a valid
					; character in an identifier
      (let ((lc-a (string-ref "a" 0))
	    (uc-a (string-ref "A" 0))
	    (lc-z (string-ref "z" 0))
	    (uc-z (string-ref "Z" 0))
	    (lbrack (string-ref "[" 0))
	    (rbrack (string-ref "]" 0))
	    (us   (string-ref "_" 0))
	    (dot  (string-ref "." 0))
	    (bang (string-ref "!" 0))
	    (zero (string-ref "0" 0))
	    (nine (string-ref "9" 0))
	    )
	(lambda (x)
	  (cond
	   ((and (>=? x lc-a) (<=? x lc-z)) #t)
	   ((and (>=? x uc-a) (<=? x uc-z)) #t)
	   ((and (>=? x zero) (<=? x nine)) #t)
	   ((=? x us) #t)
	   ((=? x bang) #t)
	   ((=? x dot) #t)
	   ((=? x lbrack) #t)
	   ((=? x rbrack) #t)
	   (#t #f)
	   )
	  )
	)
      )

     (prs.error				; Print an error message out to the
					; screen, and abort evaluation
      (lambda (str)
	(begin
	  (echo
	   -n
	   (string-append 
	    "Error"
	    (if (zero? parse-position)
		","
		(string-append
		 ", parsed `"
		 (string-append (substring parse-string 0 parse-position) "',")
		 )
		)
	    )
	   )
	  (echo -n "looking at: ")
	  (echo
	   (string-append 
	    (string-append 
	     "`"
	     (substring parse-string parse-position parse-string-len)
	     )
	    "'"
	    )
	   )
	  (error str)
	  )
	)
      )

     (have?				; #t if the next character matches
					; its argument exactly. If so, the
					; position in the string is advanced
					; and skip trailing whitespace.
      (lambda (char)
	(if (=? (string-ref parse-string parse-position) char)
	    (begin
	      (set! parse-position (+ parse-position 1))
	      #t
	      )
	    #f
	    )
	)
      )

     (skipspace				; skip leading spaces
      (lambda ()
	(cond ((=? parse-position parse-string-len) #t)
	      ((=? (string-ref parse-string parse-position)
		   (string-ref " " 0))
	       (begin
		 (set! parse-position (+ parse-position 1))
		 (skipspace)
		 )
	       )
	      (#t #t)
	      )
	)
      )
     
     (skipchar				; Expect to see a specific character
					; and skip it. Report an error if
					; invalid character
      (lambda (char)
	(if (have? char) #t (prs.error (string-append 
					"Expected: "
					(string-set! " " 0 char))
				       )
	    )
	)
      )
     
     (skip				; Expect to see a string, and skip it
					; Reports an error otherwise.
					; len is the length of the string.
      (lambda (str len)
	(letrec
	    ((len2 (+ len parse-position))
	     (helper
	      (lambda (pos1 pos2)
		(cond
		 ((=? pos1 len) 
		  (begin
		    (set! parse-position pos2)
		    #t
		    ))
		 ((=? pos2 len2) 
		  (prs.error (string-append "Expected: " str)))
		 ((=? (string-ref parse-string pos2)
		      (string-ref str pos1))
		  (helper (+ pos1 1) (+ pos2 1))
		  )
		 (#t (prs.error (string-append "Expected: " str)))
		 )
		)
	      )
	     )
	  (helper 0 parse-position)
	  )
	)
      )

     (expr				; Parse an expression
      (lambda ()
	(begin
	  (define x (term))
	  (cond 
	   ((=? parse-position parse-string-len) x)
	   ((have? or-char) (begin (skipspace) (list 'or x (expr))))
	   (#t x)
	   )
	  )
	)
      )
     
     (term				; Parse a term
      (lambda ()
	(begin
	  (define x (factor))
	  (cond 
	   ((=? parse-position parse-string-len) x)
	   ((have? and-char) (begin (skipspace) (list 'and x (term))))
	   (#t x)
	   )
	  )
	)
      )

     (factor				; parse a factor
      (lambda ()
	(cond 
	 ((have? not-char) (begin (skipspace) (list 'not (variable))))
	 ((have? lparens-char)
	  (begin
	    (skipspace)
	    (define x (expr))
	    (skipchar rparens-char)
	    (skipspace)
	    x
	    )
	  )
	 (#t (variable))
	 )
	)
      )

     (variable				; parse a variable
      (lambda ()
	(letrec ((helper
		  (lambda (pos)
		    (cond
		     ((=? parse-string-len pos) pos)
		     ((idchar? (string-ref parse-string pos))
		      (helper (+ pos 1))
		      )
		     (#t pos)
		     )
		    )
		  ))
	  (begin
	    (if (=? parse-string-len parse-position)
		(prs.error "Expected an identifier")
		#t)
	    (if (startid? (string-ref parse-string parse-position))
		#t
		(prs.error "Expected an identifier")
		)
	    (define x (helper (+ parse-position 1)))
	    (define y (substring parse-string parse-position x))
	    (set! parse-position x)
	    (skipspace)
	    y
	    )
	  )
	)
      )
     )
  (set!
   prs.parse
   (lambda (str)
     (begin
       (set! parse-string str)
       (set! parse-position 0)
       (set! parse-string-len (string-length str))
       (skipspace)
       (define x (expr))
       (skipspace)
       (skip "->" 2)
       (skipspace)
       (define y (variable))
       (collect-garbage)
       (cond ((have? plus-char) (list x y))
	     ((have? minus-char) (list x y))
	     (#t (prs.error "Expected a `+' or `-'"))
	     )
       )
     )
   )
  )



;------------------------------------------------------------------------------
;
;  Drawing a production rule
;  ~~~~~~~~~~~~~~~~~~~~~~~~~
;
;  (prs.draw width "production-rule")
;
;  Draws the transistor stacks for the specified production rules,
;  with diffusion stacks "width" wide.
;
;
;  (prs.mgn widthp widthn "prs1" "prs2" . . .)
;
;  Draw transistor stacks for the production rules specified. The network
;  is generated assuming that the rules for all the pull-up networks are
;  pairwise mutually exclusive, and that the rules for all the pull-down
;  networks are pairwise mutually exclusive. This permits a degree of
;  gate-sharing. (Not currently implemented)
;
;------------------------------------------------------------------------------
;
; Network description:
;
;      ("node" ("gate" ref-to-node)) ("gate" ref-to-node) . . .)
;
;
; A stack:
;     ("node" "edge" "node" "edge" "node" "edge")
;
;
; Temporary description:
;    ("node" ref-to-a-stack ref-to-e1 ref-to-e2 . . .)
;
;                edge = (label ref-v1 ref-v2), or (label)
;
;

(define prs.net-add-edge ())
(define prs.net-find ())
(define prs.gen-stacks ())

(letrec
    (
     (stacks-so-far ())			; stacks that have been generated
					; by the algorithm so far

;------------------------------------------------------------------------
; Insert an empty list as the second element after the node for each    
; node in the network. This is used for folding loops back into the main
; transistor stack chain, if possible.
;------------------------------------------------------------------------
     (add-empty-path
      (lambda (net)
	(if (null? net) #t
	    (begin
	      (set-cdr! (car net) (cons () (cdar net)))
	      (add-empty-path (cdr net))
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; Delete leading edges which have already been inspected by the stack
; generation algorithm. Inspected edges have their node references
; deleted, and so the list representing the edge has length 1.
;------------------------------------------------------------------------
     (strip-used-edges
      (lambda (noderef)
	(cond
	 ((null? (cddr noderef)) #t)
	 ((=? (length (caddr noderef)) 1)
	  (begin (set-cdr! (cdr noderef) (cdddr noderef))
		 (strip-used-edges noderef)
		 )
	  )
	 (#t #t)
	 )
	)
      )

;------------------------------------------------------------------------
; Generate one stack, eliminating edges used from the graph. The stack
; begins from the node pointed to by network.
;------------------------------------------------------------------------
     (generate-stack
      (lambda (network)
	(if (null? (cddr network)) (list network)
	    (cons network
		  (cons 
		   (car (caddr network))
		   (begin
		     (define edge (caddr network))
		     (define n1 (cadr edge))
		     (define n2 (caddr edge))
		     (set-cdr! (caddr network) ())
		     (set-cdr! (cdr network) (cdddr network))
		     (strip-used-edges n1)
		     (strip-used-edges n2)
		     (generate-stack (if (eqv? n1 network) n2 n1))
		     )
		   )
		  )
	    )
	)
      )


;------------------------------------------------------------------------
; Returns the last-but-1 cons cell in a stack, setting a node to a loop
; node if it has been used in a previously defined stack.
;------------------------------------------------------------------------
     (last-but-1-element
      (lambda (stk)
	(if (null? (cddr stk)) stk (last-but-1-element (cdr stk)))
	)
      )


;------------------------------------------------------------------------
; Generate all stacks. Iterate the stack generation phase until all edges
; have been inspected.
;------------------------------------------------------------------------
     (all-stacks
      (lambda (network)
	(cond
	 ((null? network) #t)
	 ((null? (cddar network)) (all-stacks (cdr network)))
	 (#t
	  (begin
	    (define stk (generate-stack (car network)))
	    (set! stacks-so-far (cons stk stacks-so-far))
	    (all-stacks network)
	    )
	  )
	 )
	)
      )

;------------------------------------------------------------------------
; Last member of a list
;------------------------------------------------------------------------
     (listlast
      (lambda (l)
	(if (null? (cdr l)) (car l) (listlast (cdr l)))
	)
      )
     

;------------------------------------------------------------------------
; Returns a list of all internal nodes in all stacks that need to be
; kept around. A node needs to be kept if there are two references to
; it.
;------------------------------------------------------------------------
     (all-used-contacts
      (lambda (stacks)
	(if (null? stacks) ()
	    (append (loose-ends (car stacks)) (allends (cdr stacks)))
	    )
	)
      )

;------------------------------------------------------------------------
; Return #t if string val is a member of list l.
;------------------------------------------------------------------------
     (ismember?
      (lambda (val l)
	(cond
	 ((null? l) #f)
	 ((string=? val (car l)) #t)
	 (#t (ismember? val (cdr l)))
	 )
	)
      )

;------------------------------------------------------------------------
; Strip internal nodes that are not from in list l from the transistor
; stack.
;------------------------------------------------------------------------
     (stripothers-1
	(lambda (stack)
	  (cond
	   ((null? stack) ())
	   ((list? (car stack))
	    (if (>? (cadar stack) 1)
		(cons (car stack) (stripothers-1 (cdr stack)))
		(stripothers-1 (cdr stack))
		)
	    )
	   (#t (cons (car stack) (stripothers-1 (cdr stack))))
	   )
	  )
	)

;------------------------------------------------------------------------
; Strip internal nodes that are not in list l from all the stacks.
;------------------------------------------------------------------------
     (stripothers
      (lambda (stacks)
	(if (null? stacks) ()
	    (cons 
	     (stripothers-1 (car stacks))
	     (stripothers (cdr stacks))
	     )
	    )
	)
      )

;------------------------------------------------------------------------
; #t if the character is a digit, #f otherwise.
;------------------------------------------------------------------------
     (digitchar?
      (let ((zero (string-ref "0" 0))
	    (nine (string-ref "9" 0))
	    )
	(lambda (x)
	  (and (>=? x zero) (<=? x nine))
	  )
	)
      )

;------------------------------------------------------------------------
; Returns #t if the string represents an internal node
;------------------------------------------------------------------------
     (internal-node? 
      (let ((x (string-ref "_" 0)))
	(lambda (str)
	  (if (=? (string-ref str 0) x)
	      (if (>? (string-length str) 1)
		  (if (digitchar? (string-ref str 1))
		      #t
		      #f
		      )
		  #f
		  )
	      #f
	      )
	  )
	)
      )

;------------------------------------------------------------------------
; Initialize a node's usecount
;------------------------------------------------------------------------
     (set-usecount-1
      (lambda (stack)
	(cond
	 ((null? stack) #t)
	 ((list? (car stack))
	  (begin
	    (set-car! (cdar stack)
		      (if (number? (cadar stack))
			  (+ 1 (cadar stack))
			  (if (internal-node? (caar stack)) 1 2)
			  )
		      )
	    (set-usecount-1 (cdr stack))
	    )
	  )
	 (#t (set-usecount-1 (cdr stack)))
	 )
	)
      )

     (set-usecount
      (lambda (stacks)
	(cond
	 ((null? stacks) #t)
	 ((null? (car stacks)) (set-usecount (cdr stacks)))
	 (#t (begin (set-usecount-1 (car stacks))
		    (set-usecount (cdr stacks)))
	     )
	 )
	)
      )

;------------------------------------------------------------------------
; Eliminate all internal nodes that are not required to construct the
; transistor stacks.
;------------------------------------------------------------------------
     (strip-dummy-contacts
      (lambda ()
	(begin
	  (set-usecount stacks-so-far)
	  (set! stacks-so-far (stripothers stacks-so-far))
	  )
	)
      )

;------------------------------------------------------------------------
; Returns #t if the stack is a loop stack.
;------------------------------------------------------------------------
     (isloop? 
      (lambda (stack)
	(eqv? (car stack) (cadr (last-but-1-element stack)))
	)
      )

;------------------------------------------------------------------------
; Separate loop and non-loop stacks.
;------------------------------------------------------------------------
     (split-stacks
      (lambda (stacks)
	(if (null? stacks) (list () () )
	    (let ((x (split-stacks (cdr stacks))))
	      (if (isloop? (car stacks))
		  (cons (cons (car stacks) (car x)) (cdr x))
		  (cons (car x) (list (cons (car stacks) (cadr x))))
		  )
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; Add a path to an existing stack
;------------------------------------------------------------------------
     (addpath
      (lambda (head stk)
	(if (null? stk) #t
	    (begin
	      (if (list? (car stk))
		  (if (null? (cadar stk))
		      (set-car! (cdar stk) (list stk head))
		      #t
		      )
		  #t
		  )
	      (addpath head (cdr stk))
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; See if there is a node on this path which belongs to an existing
; loop path
;------------------------------------------------------------------------
     (check-path
      (lambda (stack)
	(cond
	 ((null? stack) ())
	 ((list? (car stack))
	  (if (null? (cadar stack)) (check-path (cdr stack)) stack)
	  )
	 (#t (check-path (cdr stack)))
	 )
	)
      )

;------------------------------------------------------------------------
; Merge loop stacks
;------------------------------------------------------------------------
     (merge-loops 
      (lambda (stacks)
	(if (null? stacks) #t
	    (begin
	      (define lb1 (last-but-1-element (car stacks)))
	      (define cur (check-path (car stacks)))
	      (addpath stacks (car stacks))
	      (if (null? cur) (merge-loops (cdr stacks))
		  (begin
		    (define cell (caadar cur))
		    (define oldcdr (cdr cell))
		    (define head (car stacks))

		    (set-cdr! cell (cdr cur))
		    (set-cdr! lb1  head)
		    (set-cdr! cur oldcdr)

		    (set-car! stacks ())
		    (merge-loops (cdr stacks))
		    )
		  )
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; Fix non-loops.
;------------------------------------------------------------------------
     (merge-nonloops
      (lambda (stacks)
	(if (null? stacks) #t
	    (begin
	      (define cur (check-path (car stacks)))
	      (if (null? cur) (merge-nonloops (cdr stacks))
		  (begin
		    (define cell (caadar cur))
		    (define oldcdr (cdr cur))
		    (define head (car (cdadar cur)))
		    (if (zero? (length (car head)))
			#t
			(begin
			  (define lb1 (last-but-1-element (car head)))
		    
			  (set-cdr! cur (cdr cell))
			  (set-cdr! lb1 (car head))
			  (set-cdr! cell oldcdr)
			  
			  (set-car! head ())
			  )
			)
		    (merge-nonloops (cdr stacks))
		    )
		  )
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; Match first/last with first/last
;------------------------------------------------------------------------
     (find-stack-match-1
      (lambda (first last stack)
	(let ((x (car (reverse stack)))
	      (y (car stack)))
	  (cond
	   ((eqv? first y) 1)
	   ((eqv? first x) 2)
	   ((eqv? last  y) 3)
	   ((eqv? last  x) 4)
	   (#t ())
	   )
	  )
	)
      )

     (find-stack-match 
      (lambda (first last stacks)
	(cond ((null? stacks) ())
	      ((null? (car stacks)) (find-stack-match first last (cdr stacks)))
	      (#t (let ((x (find-stack-match-1 first last (car stacks))))
		    (if (null? x)
			(find-stack-match first last (cdr stacks))
			(list x stacks)
			)
		    )
		  )
	      )
	)
      )

;------------------------------------------------------------------------
; Fix straight lines that might now be linked because of the merge
; loops with non-loops phase.
;------------------------------------------------------------------------
     (fix-non-loops 
      (lambda (stacks)
	(if (null? stacks) #t
	    (if (null? (car stacks)) (fix-non-loops (cdr stacks))
		(begin
		  (define stk (find-stack-match
			       (caar stacks) 
			       (car (reverse (car stacks)))
			       (cdr stacks)
			       )
		    )
		  (if (null? stk) #t
		      (begin
			(define stks-new (cadr stk))
			(cond
			 ((=? (car stk) 1)
			  (begin
			    (define x (reverse (car stacks)))
			    (define y (last-but-1-element x))
			    (set-cdr! y (car stks-new))
			    (set-car! stks-new x)
			    )
			  )
			 ((=? (car stk) 2) 
			  (begin
			    (define x (car stks-new))
			    (define y (last-but-1-element x))
			    (set-cdr! y (car stacks))
			    )
			  )
			 ((=? (car stk) 3)
			  (begin
			    (define x (car stacks))
			    (define y (last-but-1-element x))
			    (set-cdr! y (car stks-new))
			    (set-car! stks-new x)
			    )
			  )
			 (#t 
			  (begin
			    (define x (reverse (car stacks)))
			    (define y (last-but-1-element (car stks-new)))
			    (set-cdr! y (car x))
			    )
			  )
			 )
			(set-car! stacks ())
			)
		      )
		  (fix-non-loops (cdr stacks))
		  )
		)
	    )
	)
      )

;------------------------------------------------------------------------
; Fix loops. Fold any loops into existing stacks, if possible.
;------------------------------------------------------------------------
     (fix-loops
      (lambda ()
	(begin
	  (define both (split-stacks stacks-so-far))
	  (define loop (car both))
	  (define non-loop (cadr both))
	  (merge-loops loop)
	  (merge-nonloops non-loop)
	  (set! stacks-so-far (append loop non-loop))
	  (fix-non-loops stacks-so-far)
	  )
	)
      )


;------------------------------------------------------------------------
; Convert network node references into node names in a transistor stack.
; Given a node reference in a stack (in which case it would be a contact,
; which is represented by a ("name")---see stack.scm), the name is the
; first member of the node list.
;------------------------------------------------------------------------
     (refs-to-names
      (lambda (stk)
	(if (null? stk) ()
	    (let ((x (if (list? (car stk)) (list (caar stk)) (car stk))))
	      (cons x (refs-to-names (cdr stk))))
	    )
	)
      )

;------------------------------------------------------------------------
; Convert all network node references into node names.
;------------------------------------------------------------------------
     (cleanup-stacks
      (lambda (stacks)
	(cond
	 ((null? stacks) ())
	 ((null? (car stacks)) (cleanup-stacks (cdr stacks)))
	 (#t (cons (refs-to-names (car stacks)) (cleanup-stacks (cdr stacks))))
	 )
	)
      )

;------------------------------------------------------------------------
; A contact is global if it ends in a !
;------------------------------------------------------------------------
     (global-node?
      (let ((bang (string-ref "!" 0)))
	(lambda (str)
	  (=? bang (string-ref str (- (string-length str) 1)))
	  )
	)
      )

;------------------------------------------------------------------------
; Locate a global variable contact if possible
;------------------------------------------------------------------------
     (locate-global-contact
      (lambda (stack)
	(if (null? stack) ()
	    (if (list? (car stack))
		(if (global-node? (caar stack)) stack
		    (locate-global-contact (cdr stack))
		    )
		(locate-global-contact (cdr stack))
		)
	    )
	)
      )

;------------------------------------------------------------------------
; Locate any contact
;------------------------------------------------------------------------
     (locate-any-contact
      (lambda (stack)
	(if (null? stack) ()
	    (if (list? (car stack))
		(if (internal-node? (caar stack))
		    (locate-any-contact (cdr stack))
		    stack
		    )
		(locate-any-contact (cdr stack))
		)
	    )
	)
      )

;------------------------------------------------------------------------
; Locate a contact that is not an internal node
;------------------------------------------------------------------------
     (user-contact
      (lambda (stack)
	(begin
	  (define x (locate-global-contact stack))
	  (if (null? x) (locate-any-contact stack) x)
	  )
	)
      )

;------------------------------------------------------------------------
; Rotate a single stack if possible so that the end-point is not an
; internal node
;------------------------------------------------------------------------
     (loop-unravel
      (lambda (stack)
	(begin
	  (define x (user-contact stack))
	  (if (null? x) stack
	      (begin
		(define hd (list (car x)))
		(define y (last-but-1-element stack))
		(set-cdr! hd (cdr x))
		(set-cdr! x ())
		(set-cdr! y stack)
		hd
		)
	      )
	  )
	)
      )

;------------------------------------------------------------------------
; If one of the final stacks is a loop stack, then you should try to make
; sure that the end-points are not internal nodes, and are preferably
; global nodes.
;------------------------------------------------------------------------
     (rotate-loops 
      (lambda (stacks)
	(if (null? stacks) #t
	    (cond 
	     ((null? (car stacks)) (rotate-loops (cdr stacks)))
	     ((isloop? (car stacks))
	      (begin
		(cond
		 ((internal-node? (caaar stacks))
		  (set-car! stacks (loop-unravel (car stacks)))
		  )
		 ((not (global-node? (caaar stacks)))
		  (set-car! stacks (loop-unravel (car stacks)))
		  )
		 (#t #t)
		 )
		(rotate-loops (cdr stacks))
		)
	      )
	     (#t (rotate-loops (cdr stacks)))
	     )
	    )
	)
      )
     )

  (begin

;------------------------------------------------------------------------
; Exported function: generate transistor stacks from a network
; description.
;------------------------------------------------------------------------
    (set!
     prs.gen-stacks
     (lambda (network)
       (begin
	 (set! stacks-so-far ())	; clear stacks
	 (add-empty-path network)	; add empty path
	 (all-stacks network)		; generate all stacks
	 (fix-loops)			; associate nodes with stacks
	 (rotate-loops stacks-so-far)	; rotate loops if possible so that
					; the stack ends are existing nodes
	 (strip-dummy-contacts)		; eliminate dummy nodes
	 (set! stacks-so-far (cleanup-stacks stacks-so-far))
	 stacks-so-far			; return
	 )
       )
     )

;------------------------------------------------------------------------
; find a node in a network.
;------------------------------------------------------------------------
     (set!
      prs.net-find
      (lambda (net node)
	(cond
	 ((null? net) ())
	 ((string=? (caar net) node) (car net))
	 (#t (prs.net-find (cdr net) node))
	 )
	)
      )

;------------------------------------------------------------------------
; Add an edge to a network. Use this function to construct the network
; graph.
;------------------------------------------------------------------------
    (set!
     prs.net-add-edge
     (lambda (network n1 g n2)
       (begin
	 (define ref-n1 (prs.net-find network n1))  ; find node 1
	 (define ref-n2 (prs.net-find network n2))  ; find node 2
	 (define edge (list g ref-n1 ref-n2))       ; create edge
	 (set-cdr! ref-n1 (cons edge (cdr ref-n1))) ; add edge to node 1
	 (set-cdr! ref-n2 (cons edge (cdr ref-n2))) ; add edge to node 2
	 )
       )
     )
    )
  )


;------------------------------------------------------------------------
(define prs.mgn ())
(define prs.mgn-node ())
(define prs.mgn-internal-node ())
(define prs.mgn-init-p-net ())
(define prs.mgn-init-n-net ())
(define prs.mgn-edge ())
(define prs.mgn-draw-p ())
(define prs.mgn-draw-n ())
(define prs.mgn-draw-tallp ())
(define prs.mgn-draw-talln ())
(define prs.draw ())
(define prs.tallmgn ())
(define prs.talldraw ())
(define prs.draw-net ())

(letrec
    (
     (gate.network ())
     (nodenumber 0)

;------------------------------------------------------------------------
; Generates a fresh internal node name
;------------------------------------------------------------------------
     (fresh-internal-node!
      (lambda ()
	(begin 
	  (define nn 
	    (string-append (string-append "_" (number->string nodenumber)) "#")
	    )
	  (set! nodenumber (+ 1 nodenumber))
	  nn
	  )
	)
      )

;------------------------------------------------------------------------
; Checks if "char" is the last non-whitespace character in "str"
;------------------------------------------------------------------------
     (ischarend?
      (lambda (str char)
	(letrec ((len (string-length str))
		 (space (string-ref " " 0))
		 (helper
		  (lambda (pos)
		    (cond 
		     ((zero? pos) #f)
		     ((=? char (string-ref str pos)) #t)
		     ((=? space (string-ref str pos)) (helper (- pos 1)))
		     (#t #f)
		     )
		    )
		  ))
	  (helper (- len 1))
	  )
	)
      )

;------------------------------------------------------------------------
; Extracts production rules ending with the character specified by the
; first character in string "last". The production rules are specified
; by a list of strings.
;------------------------------------------------------------------------
     (getprs
      (lambda (rule-list last)
	(cond ((null? rule-list) ())
	      ((ischarend? (car rule-list) (string-ref last 0))
	       (cons (car rule-list) (getprs (cdr rule-list) last)))
	      (#t (getprs (cdr rule-list) last))
	      )
	)
      )

;------------------------------------------------------------------------
;
; Simple transistor network generation
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;
; Direct generation of a simple network for a production rule is done by
; the intuitive rules for drawing transistors for a pull-up/pull-down:
;
; Given two gate networks *-n1-* and *-n2-*, their and-combination is
; given by *-n1-+-n2-*, and their or-combination is given by
;              *-n1-*
;              `-n2-'
; In the first case, we need to generate a name for the intermediate
; node name in the network graph.
;
; A partial network *-n-* is represented by a list of potential edges.
; An edge (transistor) is a list (x "label" y), where x and y represent 
; the end-points. If an end-point is not connected, it is a number (0).
; Connected end-points are strings.
;
; The or-combination of two networks is simply the union of the two
; networks, and the and-combination is generated by generating a new
; name for the intermediate node, connecting all right end-points of
; network n1 to that node, and connecting all left end-points of network
; n2 to the same node. The final network is the union of the two networks.
;
; The left and right end-points for the entire network corresponding to
; a pull-up/pull-down are connected to the power supply and output
; respectively.
;
;------------------------------------------------------------------------

;------------------------------------------------------------------------
; Connect the right hanging nodes to str deleting any edges that were
; generated as a result, and return the new edge list.
;------------------------------------------------------------------------
     (fillright 
      (lambda (l str)
	(cond
	 ((null? l) ())
	 ((number? (caddar l))
	  (begin
	    (set-car! (cddar l) str)
	    (if (number? (caar l))
		(cons (car l) (fillright (cdr l) str))
		(begin
		  (prs.net-add-edge gate.network (caar l) (cadar l) (caddar l))
		  (fillright (cdr l) str)
		  )
		)
	    )
	  )
	 (#t (cons (car l) (fillright (cdr l) str)))
	 )
	)
      )
     
;------------------------------------------------------------------------
; Connect the left hanging edges to node str deleting any edges that
; were generated as a result, and return the new edge list.
;------------------------------------------------------------------------
     (fillleft
      (lambda (l str)
	(cond
	 ((null? l) ())
	 ((number? (caar l))
	  (begin
	    (set-car! (car l) str)
	    (if (number? (caddar l))
		(cons (car l) (fillleft (cdr l) str))
		(begin
		  (prs.net-add-edge gate.network (caar l) (cadar l) (caddar l))
		  (fillleft (cdr l) str)
		  )
		)
	    ))
	 (#t (cons (car l) (fillleft (cdr l) str)))
	 )
	)
      )


;------------------------------------------------------------------------
; Generate the network for a boolean expression. "tree" is the parse tree
; for the expression, and "type" is zero for a pull-down chain and one
; for a pull-up chain.
;------------------------------------------------------------------------
     (gen-1-network
      (lambda (tree type)
	(cond
	 ((string? tree)
	  (if (zero? type)
	      (list (list 0 tree 0))
	      (error "A pull-up must use inverted variables only")
	      )
	  )
	 ((eqv? 'not (car tree))
	  (if (zero? type)
	      (error "A pull-down must use uninverted variables only")
	      (list (list 0 (cadr tree) 0))
	      )
	  )
	 (#t
	  (begin
	    (define l (gen-1-network (cadr tree) type))
	    (define r (gen-1-network (caddr tree) type))
	    (if (eqv? 'and (car tree))
		(begin
		  (define nn (fresh-internal-node!))
		  (set! gate.network (cons (list nn) gate.network))
		  (set! l (fillright l nn))
		  (set! r (fillleft r nn))
		  )
		#t
		)
	    (append l r)
	    )
	  )
	 (#t (error "This should not happen!"))
	 )
	)
      )

;------------------------------------------------------------------------
; Generate network corresponding to a production rule.
;------------------------------------------------------------------------
     (gen-one-network
      (lambda (rule type)
	(begin
	  (define prs (prs.parse rule))
	  (define l (gen-1-network (car prs) type))
	  (if (null? (prs.net-find gate.network (cadr prs)))
	      (set! gate.network (cons (list (cadr prs)) gate.network))
	      #t
	      )
	  (fillleft l (if (zero? type) "GND!" "Vdd!"))
	  (fillright l (cadr prs))
	  )
	)
      )

;------------------------------------------------------------------------
; Generate a network corresponding to all the rules. The rules must all be
; either describing pull-ups or pull-downs.
;------------------------------------------------------------------------
     (gen-network
      (lambda (rules type)
	(if (null? rules) #t
	    (begin
	      (gen-one-network (car rules) type)
	      (gen-network (cdr rules) type)
	      )
	    )
	)
      )


;------------------------------------------------------------------------
; Draw all the stacks in "stacks" with width "width" using function
; "draw", spaced horizontally by "spacing".
;------------------------------------------------------------------------
     (drawstacks
      (lambda (draw width stacks spacing)
	(if (null? stacks)
	    (begin
	      (box.move (uminus spacing) 0)
	      ()
	      )
	    (begin
	      (define ret-box (draw width (car stacks)))
	      (box.move spacing 0)
	      (define ret2-box (drawstacks draw width (cdr stacks) spacing))
	      (if (null? ret2-box)
		  ret-box
		  (list (min (car ret-box) (car ret2-box))
			(min (cadr ret-box) (cadr ret2-box))
			(max (caddr ret-box) (caddr ret2-box))
			(max (cadddr ret-box) (cadddr ret2-box))
			)
		  )
	      )
	    )
	)
      )

;------------------------------------------------------------------------
; Create and draw all the stacks for a set of rules.
;------------------------------------------------------------------------
     (genstacks
      (lambda (draw width rules type supply)
	(begin
	  (echo -n "Generating network...")
	  (set! gate.network (list (list supply)))
	  (gen-network rules type)
	  (echo -n "generating stacks...")
	  (define stacks (prs.gen-stacks gate.network))
	  (echo "done.")
	  (drawstacks draw width stacks
		      (+ width
			 (max 
			  (drc.min-spacing
			   (if (zero? type) "ndiff-ndiff" "pdiff-pdiff"))
			  (+ (drc.min-spacing "poly")
			     (* 2 (drc.min-overhang "gate-poly"))
			     )
			  )
			 )
		      )
	  )
	)
      )
     )
  (begin
    (set!
     prs.mgn-internal-node
     (lambda ()
       (begin
	 (define nn (fresh-internal-node!))
	 (set! gate.network (cons (list nn) gate.network))
	 nn
	 )
       )
     )
    (set!
     prs.mgn-node
     (lambda (name)
       (begin
	 (if (string? name) #t
	     (error "Usage: prs.mgn-node \"name\"")
	     )
	 (set! gate.network (cons (list name) gate.network))
	 name
	 )
       )
     )
    (set!
     prs.mgn-init-p-net
     (lambda ()
       (set! gate.network (list (list "Vdd!")))
       )
     )
    (set!
     prs.mgn-init-n-net
     (lambda ()
       (set! gate.network (list (list "GND!")))
       )
     )
    (set!
     prs.mgn-edge
     (lambda (n1 lab n2)
       (if (string-list? (list n1 lab n2))
	   (prs.net-add-edge gate.network n1 lab n2)
	   (error "Usage: prs.mgn-edge node1 \"gate\" node2")
	   )
       )
     )
    (set!
     prs.mgn-draw-p
     (lambda (width)
       (begin
	 (if (number? width)
	     #t
	     (error "Usage: prs.mgn-draw-p <width>")
	     )
         (box.push (getbox))
	 (echo -n "generating stacks...")
	 (define stacks (prs.gen-stacks gate.network))
	 (echo "done.")
         (define d
	 (drawstacks stack.p width stacks
		     (+ width
			(max 
			 (drc.min-spacing "pdiff-pdiff")
			 (+ (drc.min-spacing "poly")
			    (* 2 (drc.min-overhang "gate-poly"))
			    )
			 )
			)
		     ))
         (box.pop)
         (collect-garbage)
         d
	 )
       )
     )
    (set!
     prs.mgn-draw-n
     (lambda (width)
       (begin
	 (if (number? width) #t
	     (error "Usage: prs.mgn-draw-n <width>")
	     )
         (box.push (getbox))
	 (echo -n "generating stacks...")
	 (define stacks (prs.gen-stacks gate.network))
	 (echo "done.")
	 (define d 
         (drawstacks stack.n width stacks
		     (+ width
			(max 
			 (drc.min-spacing "ndiff-ndiff")
			 (+ (drc.min-spacing "poly")
			    (* 2 (drc.min-overhang "gate-poly"))
			    )
			 )
			)
		     ))
         (box.pop)
         (collect-garbage)
         d
	 )
       )
     )
    (set!
     prs.mgn-draw-tallp
     (lambda (width)
       (begin
	 (if (number? width) #t
	     (error "Usage: prs.mgn-draw-tallp <width>")
	     )
         (box.push (getbox))
	 (echo -n "generating stacks...")
	 (define stacks (prs.gen-stacks gate.network))
	 (echo "done.")
         (define d
	 (drawstacks stack.tallp width stacks
		     (+ width
			(max 
			 (drc.min-spacing "pdiff-pdiff")
			 (+ (drc.min-spacing "poly")
			    (* 2 (drc.min-overhang "gate-poly"))
			    )
			 )
			)
		     ))
         (box.pop)
         (collect-garbage)
         d
	 )
       )
     )
    (set!
     prs.mgn-draw-talln
     (lambda (width)
       (begin
	 (if (number? width) #t
	     (error "Usage: prs.mgn-draw-talln <width>")
	     )
         (box.push (getbox))
	 (echo -n "generating stacks...")
	 (define stacks (prs.gen-stacks gate.network))
	 (echo "done.")
         (define d
	 (drawstacks stack.talln width stacks
		     (+ width
			(max 
			 (drc.min-spacing "ndiff-ndiff")
			 (+ (drc.min-spacing "poly")
			    (* 2 (drc.min-overhang "gate-poly"))
			    )
			 )
			)
		     ))
         (box.pop)
         (collect-garbage)
         d
	 )
       )
     )
    (set!
     prs.mgn
     (eval (list
	    'lambda 
	    (cons 'widthp (cons 'widthn 'rule-list))
	    '(let* ((p-rules (getprs rule-list "+"))
		    (n-rules (getprs rule-list "-"))
		    )
	       (begin
		 (if (and (and (number? widthp) (number? widthn))
			  (string-list? rule-list))
		     #t
		     (error "Usage: prs.mgn <p-width> <n-width> \"prs1\" ...")
		     )
		 (box.push (getbox))
		 (define r1
		   (genstacks stack.p widthp p-rules 1 "Vdd!")
		   )
		 (box.move (+ widthp (drc.min-spacing "pdiff-ndiff")) 0)
		 (define r2
		   (genstacks stack.n widthn n-rules 0 "GND!")
		   )
		 (box.pop)
                 (collect-garbage)
		 (list r1 r2)
		 )
	       )
	    )
	   )
     )
    (set!
     prs.draw
      (lambda (width rule)
	(let 
	    ((x (list rule)))
	  (begin
	    (if (and (number? width) (string? rule)) #t
		(error "Usage: prs.draw <width> \"prs\"")
		)
	    (if (ischarend? rule (string-ref "+" 0))
		(genstacks stack.p width x 1 "Vdd!")
		(genstacks stack.n width x 0 "GND!")
		)
	    )
	  )
	)
      )
    (set! 
     prs.draw-net
     (lambda (rule)
       (begin
	 (if (string? rule) #t
	     (error "Usage: prs.draw-net \"prs\"")
	     )
	 (if (ischarend? rule (string-ref "+" 0))
	     (gen-one-network rule 1)
	     (gen-one-network rule 0)
	     )
	 )
       )
     )
    (set!
     prs.tallmgn
     (eval (list
	    'lambda 
	    (cons 'widthp (cons 'widthn 'rule-list))
	    '(let* ((p-rules (getprs rule-list "+"))
		    (n-rules (getprs rule-list "-"))
		    )
	       (begin
		 (if (and (and (number? widthp) (number? widthn))
			  (string-list? rule-list))
		     #t
		     (error "Usage: prs.tallmgn <p-width> <n-width> \"prs1\" ...")
		     )
		 (box.push (getbox))
		 (define r1
		   (genstacks stack.tallp widthp p-rules 1 "Vdd!")
		   )
		 (box.move (+ widthp (drc.min-spacing "pdiff-ndiff")) 0)
		 (define r2
		   (genstacks stack.talln widthn n-rules 0 "GND!")
		   )
		 (box.pop)
                 (collect-garbage)
		 (list r1 r2)
		 )
	       )
	    )
	   )
     )
    (set!
     prs.talldraw
      (lambda (width rule)
	(let 
	    ((x (list rule)))
	  (begin
	    (if (and (number? width) (string? rule)) #t
		(error "Usage: prs.talldraw <width> \"prs\"")
		)
	    (if (ischarend? rule (string-ref "+" 0))
		(genstacks stack.tallp width x 1 "Vdd!")
		(genstacks stack.talln width x 0 "GND!")
		)
	    )
	  )
	)
      )
    )
  )


(define prs.mgn-fresh-node
  (let ((x 0))
    (lambda ()
      (begin 
	(define name (string-append 
		      (string-append "_i" (number->string x))
		      "#"
		      )
	  ) 
	(set! x (+ x 1)) 
	(prs.mgn-node name)
	)
      )
    )
  )

(define prs.mgn-output-edge 
  (lambda (a b c)
    (prs.mgn-edge a b c)
    )
  )