; sword : size of a word in stack
; saddr : number of bits to address the stack (stkdepth = log(depth of stack))
; pt : number of bits for program counter (pt = log (size of imem))
; ptcbuf : number of bits to address internal buffer (ptcbuf = log (size of internal buffer cbuf))
; We assume that pt > ptcbuf (I should modify it to allow pt = ptcbuf as well padding is only done for ptcbuf)

; Helper functions
(setf *print-pretty* t)
(defvar *bat2aig* "bat2aig")
(defvar *cnf2aig* "cnf2aig")
(defvar *bat2cnf* "bat2cnf")

(defun mashup-symbol (&rest objects)
  (intern (format nil "~{~a~}" objects)))

(defun make-unsigned (n)
  (mashup-symbol n 'u))

(defun unroll-impl-next-stk-aux (n ssz sword topsz sks)
  (if (= n 1)
      (if sks
          `(((nstk0 ntop0)
            (impl-next-stk-top stk (gcmdimpl cbuf ,(make-unsigned 0)) top)))
        `((((nstk0 ,ssz ,sword) (ntop0 ,topsz))
           (impl-next-stk-top stk (gcmdimpl cbuf ,(make-unsigned 0)) top))))
    (let ((loc (make-unsigned (- n 1)))
          (nstk (mashup-symbol 'nstk (- n 1)))
          (nstkp (mashup-symbol 'nstk (- n 2)))
          (ntop (mashup-symbol 'ntop (- n 1)))
          (ntopp (mashup-symbol 'ntop (- n 2))))
      (cons 
       (if sks
           `((,nstk ,ntop)
             (impl-next-stk-top ,nstkp (gcmdimpl cbuf ,loc) ,ntopp))
         `(((,nstk ,ssz ,sword) (,ntop ,topsz))
           (impl-next-stk-top ,nstkp (gcmdimpl cbuf ,loc) ,ntopp)))
       (unroll-impl-next-stk-aux (- n 1) ssz sword topsz sks)))))

(defun unroll-impl-next-stk (n ssz sword topsz sks)
  (let ((loc (make-unsigned n)))
    `((= ptcbuf ,loc)
       (local ,(reverse (unroll-impl-next-stk-aux n ssz sword topsz sks)) 
              (mv ,(mashup-symbol 'nstk (- n 1)) ,(mashup-symbol 'ntop (- n 1)))))))

(defun impl-observable-stk-step-body-aux (n ssz sword topsz sks)
  (if (= n 0)
      `(((= ptcbuf ,(make-unsigned n))
         (mv stk top)))
    (cons (unroll-impl-next-stk n ssz sword topsz sks)
          (impl-observable-stk-step-body-aux (- n 1) ssz sword topsz sks))))

(defun impl-observable-stk-step-body (n ssz sword topsz sks)
  (cons 'cond (reverse (append '((0b1 (mv stk top)))
                               (impl-observable-stk-step-body-aux n ssz sword topsz sks)))))



(defun zero-padding (n)
  (if (= n 0)
      nil
    (cons '0b0 (zero-padding (- n 1)))))

(defun match-bit-width (ptsz ptbufsz vname)
  (if (< ptsz ptbufsz)
      (format t "Imem size is smaller than cbuf size")
    (if (= ptsz ptbufsz)
        vname
      (cons 'cat (append (zero-padding (- ptsz ptbufsz)) (list 'ptcbuf))))))

(defun unroll-impl-step-aux (n)
  (if (<= n 0)
      nil
    (if (= n 1)
        '(((cmds1 pt1 stk1 top1 cbuf1 ptcbuf1 done1 cmds-done1)
           (impl-step cmds cpt stk top cbuf 0u done ccmds-done)))
      (let* ((pn (- n 1))
             (pcmds (mashup-symbol 'cmds pn))
             (ppt (mashup-symbol 'pt pn))
             (pstk (mashup-symbol 'stk pn))
             (ptop (mashup-symbol 'top pn))
             (pcbuf (mashup-symbol 'cbuf pn))
             (pptcbuf (mashup-symbol 'ptcbuf pn))
             (pdone (mashup-symbol 'done pn))
             (pcmds-done (mashup-symbol 'cmds-done pn))
             (ccmds (mashup-symbol 'cmds n))
             (cpt (mashup-symbol 'pt n))
             (cstk (mashup-symbol 'stk n))
             (ctop (mashup-symbol 'top n))
             (ccbuf (mashup-symbol 'cbuf n))
             (cptcbuf (mashup-symbol 'ptcbuf n))
             (cdone (mashup-symbol 'done n))
             (ccmds-done (mashup-symbol 'cmds-done n)))
        (cons `((,ccmds ,cpt ,cstk ,ctop ,ccbuf ,cptcbuf ,cdone ,ccmds-done)
                (impl-step ,pcmds ,ppt ,pstk ,ptop ,pcbuf ,pptcbuf ,pdone ,pcmds-done))
              (unroll-impl-step-aux (- n 1)))))))
  
(defun unroll-impl-step (n)
  (reverse (unroll-impl-step-aux n)))


(defun compare-state-from-committed-state-aux (n)
  (if (= n 0)
       '(((= ptcbuf 0u)
         0b1))
    (let ((ncmds (mashup-symbol 'cmds n))
          (npt (mashup-symbol 'pt n))
          (nstk (mashup-symbol 'stk n))
          (ntop (mashup-symbol 'top n))
          (nptcbuf (mashup-symbol 'ptcbuf n))
          (ncbuf (mashup-symbol 'cbuf n))
          (ncmds-done (mashup-symbol 'cmds-done n))
          (ndone (mashup-symbol 'done n)))
      (cons `((= ptcbuf ,(make-unsigned n))
              (and (= ,ncmds cmds)
              (= ,npt pt)
              (= ,nstk stk)
              (= ,ntop top)
              (= ,nptcbuf ptcbuf)
              (= ,ncbuf cbuf)
              (= ,ncmds-done cmds-done)
              (= ,ndone done)))
            (compare-state-from-committed-state-aux (- n 1))))))

(defun compare-state-from-committed-state (n)
  (reverse (compare-state-from-committed-state-aux n)))

(defun compare-impl-and-spec-state-aux (n)
  (if (= n 0)
      nil
    (let ((sstk (mashup-symbol 'sstk n))
          (stop (mashup-symbol 'stop n))
          (spt (mashup-symbol 'spt n))
          (sdone (mashup-symbol 'sdone n)))
      (cons `(and (= nistk ,sstk)
                  (= nitop ,stop)
                  (= nript ,spt)
                  (= nidone ,sdone))
            (compare-impl-and-spec-state-aux (- n 1))))))

(defun compare-impl-and-spec-state (n)
  (reverse (compare-impl-and-spec-state-aux n)))


(defun unroll-spec-step-aux (n)
  (if (= n 1)
      '(((scmds1 spt1 sstk1 stop1 sdone1)
         (spec-step cmds spt sstk stop sdone)))
    (let* ((scmds (mashup-symbol 'scmds n))
          (spt (mashup-symbol 'spt n))
          (sstk (mashup-symbol 'sstk n))
          (sstop (mashup-symbol 'stop n))
          (sdone (mashup-symbol 'sdone n))
          (pn (- n 1))
          (pscmds (mashup-symbol 'scmds pn))
          (pspt (mashup-symbol 'spt pn))
          (psstk (mashup-symbol 'sstk pn))
          (pstop (mashup-symbol 'stop pn))
          (psdone (mashup-symbol 'sdone pn)))
      (cons `((,scmds ,spt ,sstk ,sstop ,sdone)
              (spec-step ,pscmds ,pspt ,psstk ,pstop ,psdone))
            (unroll-spec-step-aux (- n 1))))))

(defun unroll-spec-step (n)
  (reverse (unroll-spec-step-aux n)))

(defun print-to-file (l name)
  (with-open-file (stream name :direction :output 
                          :if-exists :overwrite
                          :if-does-not-exist   :create)
    (dolist (item l) (write-line (format nil "~(~A~)" item) stream))))


;; functions common to both specification and implementation 
;; operations on memory (read,write,refresh)


; spec-step 
(defun spec-functions (op sword stkdepth ptsz)
  (let* ((ssz (expt 2 stkdepth))
         (topsz (+ 1 stkdepth))
         (isz (expt 2 ptsz))
         (cmdsz (+ sword op)))
    `(
      (spec-next-stk-top 
       ((,ssz ,sword) (,topsz)) ((stk ,ssz ,sword) (top ,topsz) (cmds ,isz ,cmdsz) (pt ,ptsz) (done 1))
       (if done
           (mv stk top)
         (local ((cmd (gcmd cmds pt))
                 (op (gop cmd))
                 (val (gval cmd))
                 (((nastk ,ssz ,sword) (natop ,topsz) (raval ,sword))
                  (cond ((= op 0u)
                         (mpush stk val top))
                        ((= op 1u)
                         (mpop stk top))
                        ((= op 2u)
                         (mhead stk top))
                        (0b1 (mv stk top 0)))))
                (mv nastk natop))))
      
      (spec-next-pt (,ptsz) ((pt ,ptsz))
                    (if (= pt ,(make-unsigned (- isz 1)))
                        pt
                      (mod+ pt 1u)))
      
      (spec-next-cmds (,isz ,cmdsz) ((cmds ,isz ,cmdsz))
                      cmds)

      (spec-next-done (1) ((cmds ,isz ,cmdsz) (pt ,ptsz))
                      (= pt ,(make-unsigned (- isz 1))))

      (spec-step ((,isz ,cmdsz) (,ptsz) (,ssz ,sword) (,topsz) (1))
                 ((cmds ,isz ,cmdsz) (pt ,ptsz) (stk ,ssz ,sword) (top ,topsz) (done 1))
                 (local ((((nstk ,ssz ,sword) (ntop ,topsz)) 
                          (spec-next-stk-top stk top cmds pt done))
                         (npt (spec-next-pt pt))
                         (ndone(spec-next-done cmds pt)))
                        (mv cmds npt nstk ntop ndone)))
      )))


(defun impl-functions (op sword stkdepth ptsz ptbufsz sks)
  (let* ((ssz (expt 2 stkdepth))
         (isz (expt 2 ptsz))
         (topsz (+ 1 stkdepth))
         (cmdsz (+ sword op))
         (cbufsz (expt 2 (- ptbufsz 1))))
    `(
      (gcmdimpl (,cmdsz) ((cbuf ,cbufsz ,cmdsz) (ptbuf ,ptbufsz))
                (get cbuf (bits ptbuf 0 ,(- ptbufsz 2))))

; stutter = true if cbuf is not full
; current commands is not a head 
      (stutterp (1) ((cmd ,cmdsz) (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz) (cmds-done 1))
                (and (> (- ,(make-unsigned cbufsz) ptcbuf) 0)
                     (not (= (gop cmd) 2u))
                     (not cmds-done)))
      

; update (stk,top) given a cmd
      (impl-next-stk-top
       ((,ssz ,sword) (,topsz)) ((stk ,ssz ,sword) (cmd ,cmdsz) (top ,topsz)) 
       (local ((op (gop cmd))
               (val (gval cmd))
               (((nastk ,ssz ,sword) (natop ,topsz) (raval ,sword))
                (cond ((= op 0u)
                       (mpush stk val top))
                      ((= op 1u)
                       (mpop stk top))
                      ((= op 2u)
                       (mhead stk top))
                      (0b1 (mv stk top 0)))))
              (mv nastk natop)))


; update (stk,top) by executing commands in cbuf 
; cmds in slots below ptcbuf are valid commands
      (impl-observable-stk-step
       ((,ssz ,sword) (,topsz))
       ((stk ,ssz ,sword) (top ,topsz) (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz))
       ,(impl-observable-stk-step-body cbufsz ssz sword topsz sks))


      (impl-stk-step 
       ((,ssz ,sword) (,topsz)) 
       ((stk ,ssz ,sword) (top ,topsz) (cbuf ,cbufsz ,cmdsz) 
        (ptcbuf ,ptbufsz) (cmds ,isz ,cmdsz) (pt ,ptsz) (done 1) (cmds-done 1))
       (if (or (stutterp (gcmd cmds pt) cbuf ptcbuf cmds-done)
               done)
           (mv stk top)
         (impl-observable-stk-step stk top cbuf ptcbuf)))

; update cbuf at slot "a" with cmd v
      ;; hack as i do not take care of constant address during get/set expansion
      (update-cbuf (,cbufsz ,cmdsz) ((cbuf ,cbufsz ,cmdsz) (a ,(- ptbufsz 1)) (v ,cmdsz))
                   (set cbuf a v))

; when stutter internal step for cbuf is insert cmd in cbuf at slot ptcbuf
; update (cbuf,ptcbuf)
      (impl-stutter-cbuf-step 
       ((,cbufsz ,cmdsz) (,ptbufsz))
       ((cmd ,cmdsz) (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz))
       (mv (update-cbuf cbuf (bits ptcbuf 0 ,(- ptbufsz 2)) cmd)
           (mod+ ptcbuf 1u)))
      
      
      (impl-no-stutter-cbuf-step 
       ((,cbufsz ,cmdsz) (,ptbufsz)) 
       ((cmd ,cmdsz) (cbuf ,cbufsz ,cmdsz) (cmds-done 1))
       (cond ((or (= (gop cmd) 2u)
                  cmds-done)
              (mv cbuf 0))
             (0b1 
              (mv (update-cbuf cbuf 0 cmd) 1u))))
      
; take internal step to update cbuf if stutterp = true else take a observable step
      (impl-next-cbuf 
       ((,cbufsz ,cmdsz) (,ptbufsz))
       ((cmds ,isz ,cmdsz) (pt ,ptsz) (cbuf ,cbufsz ,cmdsz) 
        (ptcbuf ,ptbufsz) (cmds-done 1))
       (local ((cmd (gcmd cmds pt)))
              (if (stutterp cmd cbuf ptcbuf cmds-done)
                  (impl-stutter-cbuf-step cmd cbuf ptcbuf)
                (impl-no-stutter-cbuf-step cmd cbuf cmds-done))))
      
; latch that we are done executing all commands in cmds and so next
; cycle just flush cbuf and then assert DONE signal
      (impl-next-cmds-done (1) ((pt ,ptsz))
                           (= pt ,(make-unsigned (- isz 1))))

; done = true if no commands to execute or current comand pointed by pt in CMDS is halt
      (impl-next-done (1) ((ptcbuf ,ptbufsz) (cmds-done 1))
                      (and cmds-done
                           (= ptcbuf 0))) ;; flushed cbuf

; increment pt if the current command being fetch from CMDS by pt is not halt
      (impl-next-pt (,ptsz) ((pt ,ptsz))
                    (if (= pt ,(make-unsigned (- isz 1)))  ;; this ensures cmds-done and
                        pt              ;; therefore done once asserted remains asserted
                      (mod+ pt 1u)))
      
      )))

(defun good-state-function (op sword stkdepth ptsz ptbufsz)
  (let* ((ssz (expt 2 stkdepth))
         (isz (expt 2 ptsz))
         (topsz (+ 1 stkdepth)) 
         (cmdsz (+ sword op))
         (cbufsz (expt 2 (- ptbufsz 1))))
    `(
      (good-state-p (1)
                    ((cmds ,isz ,cmdsz) (pt ,ptsz) (stk ,ssz ,sword) (top ,topsz) 
                     (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz) (done 1) (cmds-done 1))
                    (local ,(append `((cpt (mod- pt ,(match-bit-width ptsz ptbufsz 'ptcbuf)))
                                      (ccmds-done (if done cmds-done 
                                                    (cond ((and cmds-done (not (= ptcbuf 0)))
                                                           0b0)
                                                          ((and cmds-done (= ptcbuf 0))
                                                           0b1)
                                                          (0b1 0b0)))))
                                    (unroll-impl-step cbufsz))
                           (and (or (> cpt 0)
                                    (= cpt 0))
                                (if done
                                    cmds-done
                                  ,(cons 'cond (compare-state-from-committed-state cbufsz)))))))))

(defun impl-step-function (op sword stkdepth ptsz ptbufsz)
  (let* ((ssz (expt 2 stkdepth))
         (isz (expt 2 ptsz))
         (topsz (+ 1 stkdepth))
         (cmdsz (+ sword op))
         (cbufsz (expt 2 (- ptbufsz 1))))    
    `((impl-step 
       ((,isz ,cmdsz) (,ptsz) (,ssz ,sword) (,topsz) (,cbufsz ,cmdsz) (,ptbufsz) (1) (1))
       ((cmds ,isz ,cmdsz) (pt ,ptsz) (stk ,ssz ,sword) (top ,topsz)
        (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz) (done 1) (cmds-done 1))
       (local (((nstk ntop) (impl-stk-step stk top cbuf ptcbuf cmds pt done cmds-done))
               (npt (impl-next-pt pt))
               ((ncbuf nptcbuf) (impl-next-cbuf cmds pt cbuf ptcbuf cmds-done))
               (ncmds-done (impl-next-cmds-done pt))
               (ndone (impl-next-done ptcbuf cmds-done)))
              (mv cmds npt nstk ntop ncbuf nptcbuf ndone ncmds-done))))))

(defun core-functions (op sword stkdepth ptsz)
  (let* ((ssz (expt 2 stkdepth))
         (topsz (+ 1 stkdepth))
         (cmdsz (+ op sword))
         (isz (expt 2 ptsz))
         (op-lo 0)
         (op-hi (- (+ op-lo op) 1)) 
         (val-lo (+ op-hi 1)) 
         (val-hi (- (+ val-lo sword) 1))) 
    `(
        (stack-not-empty-p (1) ((top ,topsz))
           (not (= top 0u)))

        (stack-not-full-p (1) ((top ,topsz))
                          (> (- ,(make-unsigned ssz) top) 0))

        (mpush ((,ssz ,sword) (,topsz) (,sword)) ((stk ,ssz ,sword) (v ,sword) (top ,topsz))
               (mv (set stk (bits top 0 ,(- topsz 2)) v) (mod+ top 1u) v))

        (mpop ((,ssz ,sword) (,topsz) (,sword)) ((stk ,ssz ,sword) (top ,topsz))
              (cond ((stack-not-empty-p top)
                     (mv stk (mod- top 1u) (get stk (bits top 0 ,(- topsz 2)))))
                    (0b1 (mv stk top 0u))))

        (mhead ((,ssz ,sword) (,topsz) (,sword)) ((stk ,ssz ,sword) (top ,topsz))
               (mv stk top (get stk (bits top 0 ,(- topsz 2)))))


      (gop (,op) ((cmd ,cmdsz))
           (bits cmd ,op-lo ,op-hi))
      
      (gval (,sword) ((cmd ,cmdsz))
            (bits cmd ,val-lo ,val-hi))
            
      (gcmd (,cmdsz) ((cmds ,isz ,cmdsz) (pt ,ptsz))
            (get cmds pt)))))

(defun generate-functions-section (op sword stkdepth ptsz ptbufsz sks)
  (let ((fns (append (core-functions op sword stkdepth ptsz)
                     (spec-functions op sword stkdepth ptsz)
                     (impl-functions op sword stkdepth ptsz ptbufsz sks))))
    (if sks
        (append fns 
                (impl-step-function op sword stkdepth ptsz ptbufsz)
                (good-state-function op sword stkdepth ptsz ptbufsz))
      (append '(":functions") fns))))
         
; transition function
(defun generate-trans-section (op sword stkdepth ptsz ptbufsz)
  (declare (ignore ptsz))
  (let* ((ssz (expt 2 stkdepth))
         (cmdsz (+  sword op))
         (topsz (+ 1 stkdepth))
         (cbufsz (expt 2 (- ptbufsz 1))))  
    `(":trans" (local 
                ((((nsstk ,ssz ,sword) (ntop ,topsz)) 
                  (spec-next-stk-top sstk stop scmds spt sdone))
                 (((instk ,ssz ,sword) (intop ,topsz))
                  (impl-stk-step istk itop cbuf ptcbuf icmds ipt idone icmds-done))
                 (((ncbuf ,cbufsz ,cmdsz) (nptcbuf ,ptbufsz))
                  (impl-next-cbuf icmds ipt cbuf ptcbuf icmds-done)))
                 (and (= (next sstk) (if (not rstl) input-stack nsstk))
                     (= (next stop) (if (not rstl) 
                                        (cat 0b0 (bits input-top 0 ,(- topsz 2))) ntop))
                     (= (next spt) (if (not rstl) 0u (spec-next-pt spt)))
                     (= (next sdone) (if (not rstl) 0u (spec-next-done scmds spt)))
                     (= (next scmds) (if (not rstl) input-cmds scmds))
                     (= (next rstl) 1u)
                     ; implementation state
                     (= (next istk) (if (not rstl) input-stack instk))
                     (= (next itop) (if (not rstl) 
                                        (cat 0b0 (bits input-top 0 ,(- topsz 2))) intop))
                     (= (next ipt) (if (not rstl) 0u 
                                     (impl-next-pt ipt)))
                     (= (next idone) (if (not rstl) 0u 
                                       (impl-next-done ptcbuf icmds-done)))
                     (= (next icmds-done) (if (not rstl) 0 
                                            (impl-next-cmds-done ipt)))
                     (= (next cbuf) (if (not rstl) 0u ncbuf))
                     (= (next ptcbuf) (if (not rstl) 0u nptcbuf))
                     (= (next icmds) (if (not rstl) input-cmds icmds)))))))

(defun io-property ()
  `(":spec" (-> (and idone sdone) 
                (and  (= sstk istk)
                      (= stop itop)
                      (= icmds scmds)
                      (= ipt spt)))))

(defun generate-stk-machine-io (op sword stkdepth ptsz ptbufsz)
  (let* ((ssz (expt 2 stkdepth))
         (isz (expt 2 ptsz))
         (topsz (+ 1 stkdepth))
         (cmdsz (+  sword op))
         (cbufsz (expt 2 (- ptbufsz 1))))
  `(":machine" (,(generate-functions-section op sword stkdepth ptsz ptbufsz nil)
                (":vars" (rstl 1) (input-cmds ,isz ,cmdsz) (input-stack ,ssz ,sword) 
                 (input-top ,topsz)   
                 (sstk ,ssz ,sword) (stop ,topsz) (scmds ,isz ,cmdsz) (spt ,ptsz)  (sdone 1) 
                 (istk ,ssz ,sword) (itop ,topsz) (icmds-done 1) (idone 1) (icmds ,isz ,cmdsz)
                 (ipt ,ptsz) (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz))
                (":init" 0b1)
                ,(generate-trans-section op sword stkdepth ptsz ptbufsz)
                ,(io-property))
    1)))

(defun good-state-inductive (n)
  `(-> (and (-> idone icmds-done)
            (< ptcbuf ,(make-unsigned (+ n 1))) 
            (good-state-p cmds ipt istk itop cbuf ptcbuf idone icmds-done))
       (and (< nptcbuf ,(make-unsigned (+ n 1)))
            (good-state-p ncmds nipt nistk nitop ncbuf nptcbuf nidone nicmds-done))))


(defun sks-property (n)
  `(-> (and (not icmds-done)
            (= sstk istk) ; w = ref-map(s)
            (= stop itop)
            (= spt ript)
            (= sdone idone)
            (< ptcbuf ,(make-unsigned (+ n 1)))
            (good-state-p cmds ipt istk itop cbuf ptcbuf idone icmds-done) ; good-map (s)
            (not (and (= istk nistk) ; (not ((ref-map s = ref-map u) /\ (< (rank u) (rank s))))
                      (= ript nript)
                      (= nidone idone)
                      (< (- ,(make-unsigned (+ n 1)) nptcbuf)
                         (- ,(make-unsigned (+ n 1)) ptcbuf)))))
       ,(cons 'or (compare-impl-and-spec-state n))))

(defun generate-sks-property (op sword stkdepth ptsz ptbufsz)
  (declare (ignore op sword stkdepth))
  (let* ((cbufsz (expt 2 (- ptbufsz 1))))
    `(local ,(append (unroll-spec-step cbufsz)
                      `(((ncmds nipt nistk nitop ncbuf nptcbuf nidone nicmds-done)
                         (impl-step icmds ipt istk itop cbuf ptcbuf idone icmds-done))
                        (ript (mod- ipt  ,(match-bit-width ptsz ptbufsz 'ptcbuf)))
                        (nript (mod- nipt ,(match-bit-width ptsz ptbufsz 'nptcbuf)))))
            (and ,(good-state-inductive cbufsz)
                 ,(sks-property cbufsz)))))


(defun generate-stk-machine-sks (op sword stkdepth ptsz ptbufsz)
  (let* ((ssz (expt 2 stkdepth))
         (isz (expt 2 ptsz))
         (topsz (+ 1 stkdepth))
         (cmdsz (+ sword op))
         (cbufsz (expt 2 (- ptbufsz 1))))
    `(":forall"
      ((sstk ,ssz ,sword) (stop ,topsz) (cmds ,isz ,cmdsz) (spt ,ptsz) (sdone 1)
       (istk ,ssz ,sword) (itop ,topsz) (icmds-done 1) (idone 1) (icmds ,isz ,cmdsz)
       (ipt ,ptsz) (cbuf ,cbufsz ,cmdsz) (ptcbuf ,ptbufsz))
      ,(generate-functions-section op sword stkdepth ptsz ptbufsz t)
      ,(generate-sks-property op sword stkdepth ptsz ptbufsz))))

(defun gen-stk-machine-io (op sword stkdepth ptsz ptbufsz fname)
  (let* ((l (generate-stk-machine-io op sword stkdepth ptsz (+ 1 ptbufsz)))         
         (bla (format t "~x~%"fname)))
    (declare (ignore bla))
    (print-to-file l fname)))

(defun gen-stk-machine-sks (op sword stkdepth ptsz ptbufsz fname)
  (let* ((l (generate-stk-machine-sks op sword stkdepth ptsz (+ 1 ptbufsz)))        
        (bla (format t "Model: ~x~%" fname)))
    (declare (ignore bla))
    (print-to-file l fname)))


(defun gen-stk-machine-aux (sword stkdepth ptsz ptbufsz sks-io fname)
  (let ((op 2))
    (if (<= ptsz ptbufsz)
        (format t "argument pt must be > than ptbuf~%")
      (if (equal sks-io "sks")
          (gen-stk-machine-sks op sword stkdepth ptsz ptbufsz fname)
        (if (equal sks-io "io")
            (gen-stk-machine-io op sword stkdepth ptsz ptbufsz fname)
          (format t "Unknownly property: io or sks~%"))))))

(defun gen-stk-machine (sword stkdepth ptsz ptbufsz sks-io)
  (let ((fname (if (equal sks-io "sks")
                   (format nil "skip-stk-~D-word-~D-ibuf-~D-imem-~D.lisp" 
                           (expt 2 stkdepth) sword (expt 2 ptbufsz) (expt 2 ptsz))
                 (if (equal sks-io "io")
                     (format nil "stk-~D-word-~D-ibuf-~D-imem-~D.lisp" 
                             (expt 2 stkdepth) sword (expt 2 ptbufsz) (expt 2 ptsz))
                   (format t "Unknownly property: io or sks~%")))))
    (gen-stk-machine-aux sword stkdepth ptsz ptbufsz sks-io fname)))

(defun run-sksbat2aig (fname)
  (sb-ext:run-program *bat2cnf* (list "-solver" "none" "-r" fname) :wait t :if-output-exists :supersede :search t)
  (let ((cnf (format nil "~A.cnf" fname))
        (aig (format nil "~A.aig" fname)))
    (sb-ext:run-program *cnf2aig* (list cnf aig) :wait t :if-output-exists :supersede :search t)))

(defun generic-run-aig (sks-io fname)
  (cond ((equal sks-io "io")
         (sb-ext:run-program *bat2aig* (list fname) :wait t :if-output-exists :supersede :search t))
        ((equal sks-io "sks")
         (run-sksbat2aig fname))
        (t nil)))

(defun gen-stk-machine-aig (sword stkdepth ptsz ptbufsz sks-io)
  (declare (special *bat2aig*))
  (let ((fname (if (equal sks-io "sks")
                   (format nil "skip-stk-~D-word-~D-ibuf-~D-imem-~D.lisp" 
                           (expt 2 stkdepth) sword (expt 2 ptbufsz) (expt 2 ptsz))
                 (if (equal sks-io "io")
                     (format nil "stk-~D-word-~D-ibuf-~D-imem-~D.lisp" 
                             (expt 2 stkdepth) sword (expt 2 ptbufsz) (expt 2 ptsz))
                   (format t "Unknownly property: io or sks~%")))))
    (gen-stk-machine-aux sword stkdepth ptsz ptbufsz sks-io fname)
      (format t "converting to aig~%")
      (format t "aig: ~x.aig~%" fname)
      (generic-run-aig sks-io fname)))

(defun print-usage()
  (format t 
          "Usage:~%
               gen-stk <sword> <saddr> <ptsz> <ptbufsz> <sks-io> ~%
               sword : number of bits in a  word in data memory~%
               saddr : number of address bits to address data memory (= log (size of data memory))~%
               ptsz : number of address bits to address imem (= log (size of instruction memory))~%
               ptbufsz : number of address bits to address internal buffer (ibuf)~%
               sks-io:  one of \"io\" or \"sks\"~%"))

(defun extract-args (l)
  (let* ((sword (parse-integer (nth 0 l)))
         (saddr (parse-integer (nth 1 l)))
         (ptsz (parse-integer (nth 2 l)))
         (ptbufsz (parse-integer (nth 3 l)))
         (sks-io (nth 4 l)))
    (values sword saddr ptsz ptbufsz sks-io)))


(defun main (&rest args)
  (cond ((or (not (equal (length args) 5))
             (equal args "-h"))
         (print-usage))
        (t (multiple-value-bind (mword maddr ptsz ptbufsz sks-io)
               (extract-args args)
             (gen-stk-machine-aig mword maddr ptsz ptbufsz sks-io)))))

   
(save-lisp-and-die
 "gen-stk"
 :toplevel (lambda ()
             (apply #'main
                    (cdr *posix-argv*)))
 :executable t)