;;; -*- mode: lisp; syntax: common-lisp -*-

(defvar *forth-operations* (make-hash-table))

(defmacro defforth (name min &body body)
  "Define a Forth command and store it in *FORTH-OPERATIONS*.

A Forth command requires one argument, called LST and returns two values,
the first is a new list and the second is whether the command succeeded."
  (let* ((fn-name (concatenate 'string "forth-" (symbol-name name)))
         (fn-symbol (intern (string-upcase fn-name))))
    `(progn
       (defun ,fn-symbol (lst)
         (if (>= (length lst) ,min)
             (values (progn ,@body) t)
             (values nil nil)))
       (setf (gethash ',name *forth-operations*) #',fn-symbol))))

(defun call-forth (fn lst)
  "Calls a Forth function of name FN with LST."
  (funcall (gethash fn *forth-operations*) lst))

(defun forth-commands (lst command-list)
  "Execute a series of Forth commands on a list.

E.g. (FORTH-COMMANDS '(A B C) '(OVER SWAP))."
  (if (null command-list)
      lst
      (forth-commands (call-forth (car command-list) lst) (cdr command-list))))

(defforth swap 2
  ;; ( b a -- a b )
  (nconc (list (second lst) (first lst))
         (nthcdr 2 lst)))

(defforth dup 1
  ;; ( a -- a a )
  (cons (first lst) lst))

(defforth over 2
  ;; ( b a -- b a b )
  (cons (second lst) lst))

(defforth rot 3
  ;; ( c b a -- b a c )
  (nconc (list (third lst) (first lst) (second lst))
         (nthcdr 3 lst)))

(defforth drop 1
  ;; ( b a -- b )
  (rest lst))

(defforth 2swap 4
  ;; ( d c b a -- b a d c )
  (nconc (list (third lst) (fourth lst) (first lst) (second lst))
         (nthcdr 4 lst)))

(defforth 2dup 2
  ;; ( b a -- b a b a )
  (nconc (list (first lst) (second lst))
         lst))

(defforth 2over 4
  ;; ( d c b a -- d c b a d c )
  (cons (caddr lst) (cons (cadddr lst) lst)))

(defforth 2rot 6
  ;; ( f e d c b a -- d c b a f e )
  (nconc (list (fifth lst) (sixth lst)
               (first lst) (second lst)
               (third lst) (fourth lst))
         (nthcdr 6 lst)))

(defforth 2drop 2
  ;; ( d c b a -- d c )
  (nthcdr 2 lst))

(defforth nip 2
  ;; ( b a -- a )
  (forth-commands lst '(swap drop)))

(defforth tuck 2
  ;; ( b a -- a b a )
  (forth-commands lst '(swap over)))



(defun find-stack-operations (from-list to-list &optional (max 5))
  "Finds the shortest list of Forth operations to convert a list to the
given form. MAX gives an upper limit to the search length.

E.g. (FIND-STACK-OPERATIONS '(A B C) '(A B C A B C))."
  (let ((from (reverse from-list))
        (to (reverse to-list)))
    (labels ((rec (lst n &optional acc)
               (cond ((equal lst to)
                      (format t "~{~a~^ ~}~%" (nreverse acc))
                      (return-from find-stack-operations t))
                     ((zerop n) nil)
                     (t (maphash (lambda (name fn)
                                   (multiple-value-bind (new-lst okayp)
                                       (funcall fn lst)
                                     (when okayp
                                       (rec new-lst (1- n) (cons name acc)))))
                                 *forth-operations*)))))
      (do ((n 0 (1+ n)))
          ((> n max) (format t "This would be too complicated.~%"))
        (rec from n)))))