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

(defparameter *whitespace-labels* (list 0 (make-hash-table)))
(defvar *whitespace-stream*)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun concatenated-symbol (&rest lst)
    (let ((strlist (mapcar #'symbol-name lst)))
      (intern (string-upcase (apply #'concatenate 'string strlist))))))

(defmacro defws (name code arglist)
  `(defun ,(concatenated-symbol 'whitespace- name) ,arglist
     (format *whitespace-stream*
             (concatenate 'string ',code
                          ,@(loop
                               for number in arglist
                               collect `(ws-number ,number))))))

(defun ws-number (n)
  (concatenate 'string (string (if (< n 0) #\Tab #\Space))
               (map 'string (lambda (x) (if (char= x #\1) #\Tab #\Space))
                    (format nil "~b" (abs n)))
               (string #\Newline)))

(defws push (#\Space #\Space) (number))
(defws dup (#\Space #\Newline #\Space) ())
(defws fetch (#\Space #\Tab #\Space) (number))
(defws swap (#\Space #\Newline #\Tab) ())
(defws drop (#\Space #\Newline #\Newline) ())
(defws ndrop (#\Space #\Tab #\Newline) (number))
(defws add (#\Tab #\Space #\Space #\Space) ())
(defws sub (#\Tab #\Space #\Space #\Tab) ())
(defws mul (#\Tab #\Space #\Space #\Newline) ())
(defws div (#\Tab #\Space #\Tab #\Space) ())
(defws mod (#\Tab #\Space #\Tab #\Tab) ())
(defws store (#\Tab #\Tab #\Space) ())
(defws retrieve (#\Tab #\Tab #\Tab) ())
(defws mark (#\Newline #\Space #\Space) (label))
(defws call (#\Newline #\Space #\Tab) (label))
(defws jmp (#\Newline #\Space #\Newline) (label))
(defws jz (#\Newline #\Tab #\Space) (label))
(defws jneg (#\Newline #\Tab #\Tab) (label))
(defws ret (#\Newline #\Tab #\Newline) ())
(defws quit (#\Newline #\Newline #\Newline) ())
(defws print-char (#\Tab #\Newline #\Space #\Space) ())
(defws print-number (#\Tab #\Newline #\Space #\Tab) ())
(defws read-char (#\Tab #\Newline #\Tab #\Space) ())
(defws read-number (#\Tab #\Newline #\Tab #\Tab) ())

(defun ws-label (label)
  (or (gethash label (second *whitespace-labels*))
      (progn
        (incf (first *whitespace-labels*))
        (setf (gethash label (second *whitespace-labels*))
              (first *whitespace-labels*)))))

(defun prepend-whitespace (tree)
  (if (consp tree)
      (if (consp (first tree))
          (cons (prepend-whitespace (first tree))
                (mapcar #'prepend-whitespace (rest tree)))
          (cons (concatenated-symbol 'whitespace- (first tree))
                (mapcar #'prepend-whitespace (rest tree))))
      (if (symbolp tree)
          `(ws-label ',tree)
          tree)))

(defmacro whitespace ((stream) &body body)
  `(let ((*whitespace-stream* ,stream))
     ,@(prepend-whitespace body)))

;;; Example: counting from 1 to 10
(whitespace (*standard-output*)
  (push 1)
  (mark loop)
  (dup)
  (print-number)
  (push 10)
  (print-char)
  (push 1)
  (add)
  (dup)
  (push 11)
  (sub)
  (jz end)
  (jmp loop)
  (mark end)
  (drop)
  (quit))

(defmacro whitespace-for (from to &body body)
  "FOR loop - the top of the stack is the loop variable."
  (let ((start (gensym "START"))
        (end (gensym "END")))
    (cons 'progn
          (append
           (prepend-whitespace
            `((push ,from)
              (mark ,start)
              (dup)
              (push ,to)
              (swap)
              (sub)
              (jneg ,end)))
           body
           (prepend-whitespace
            `((push 1)
              (add)
              (jmp ,start)
              (mark ,end)
              (drop)))))))

;;; The same example, using FOR:
(whitespace (*standard-output*)
  (for 1 10
       (dup)
       (print-number)
       (push 10)
       (print-char))
  (quit))

;;; SPOJ/3
(whitespace (*standard-output*)
  (for 1 24
       (for 0 9 (dup) (read-char))
       (push 10) (read-char)            ; Space
       (for 10 14 (dup) (read-char))
       (push 15) (read-char)            ; Newline
       (for 0 5
            (for 0 4                    ; i j k
                 (dup)                  ; i j k k
                 (dup) (fetch 3) (add)  ; i j k k j+k
                 (retrieve)             ; i j k k x(j+k)
                 (swap) (push 10) (add) ; i j k x(j+k) 10+k
                 (retrieve)             ; i j k x(j+k) x(10+k)
                 (sub)
                 (jz same)
                 (drop)
                 (jmp not-the-same)
                 (mark same))
            (drop)
            (jmp substring)
            (mark not-the-same))
       (push 0) (print-number)
       (jmp end)
       (mark substring)
       (push 1) (print-number)
       (mark end)
       (push 10) (print-char))
  (quit))