(in-package txt2web.lib)

;;;; Parenscript macros which make the parser's intermediate
;;;; representation directly compilable by Parenscript
;;;; Some utility macros for other .ps sources too.

;;;; Block type | Has own locals | Has labels | async
;;;  Location   | TRUE           | TRUE       | TRUE
;;;  Act        | TRUE           | TRUE       | TRUE
;;;  {}         | TRUE           | TRUE       | TRUE
;;;  IF         | FALSE          | TRUE       | TRUE
;;;  FOR        | FALSE          | TRUE       | TRUE
;;;  
;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops.
;;; Jumps back are also optimized to Javascript's while loops.

;;; Utils

;;; Common

(defpsmacro label-block (() &body body)
  (let ((has-labels (some #'keywordp body)))
    `(block nil
       ,@(when has-labels
           '((var _labels (list))))
       (tagbody
          ,@body
          (void)))))

(defpsmacro str (&rest forms)
  (cond ((zerop (length forms))
         "")
        ((and (= 1 (length forms))
              (stringp (first forms)))
         (first forms))
        (t
         `(& ,@forms))))

(defpsmacro locals-block (&body body)
  "Includes labels too (through qsp-lambda)"
  (let ((*locals* nil))
    (walker:walk 'locals body)
    `(qsp-lambda
      (create-locals ,*locals*)
      ,@(walker:walk 'apply-vars body))))

;;; 1loc

(defparameter *special-variables*
  '((usehtml 0)
    (result 0)
    ($result 0)
    ($ongload 0)
    ($ongsave 0)
    ($onobjadd 0)
    ($onobjdel 0)
    ($onobjsel 0)
    ($onnewloc 0)
    ($onactsel 0)
    ($counter 0)
    ($usercom 0)))

(defpsmacro game ((name) &body body)
  (setf body (walker:walk 'for-transform body))
  (setf *globals* *special-variables*)
  (walker:walk 'globals body)
  `(progn
     ;; Game object
     (setf (@ *games ,name)
           (create))
     ;; Global variables from this game
     (create-globals ,*globals*)
     ;; Locations
     ,@(loop :for location :in body
          :collect `(setf (@ *games ,name ,(caadr location))
                          ,location))))

(defpsmacro location ((name) &body body)
  (declare (ignore name))
  "Name is used by the game macro above"
  `(locals-block ,@body))

(defpsmacro goto% (target &rest args)
  `(progn
     (goto ,target ,args)
     (exit)))

(defpsmacro xgoto% (target &rest args)
  `(progn
     (xgoto ,target ,args)
     (exit)))

;;; 2var

(defvar *globals* nil)
(defvar *locals* nil)

(defpsmacro create-globals (globals)
  (flet ((indexes (name)
           (remove nil
                   (remove-if #'listp
                              (mapcar #'second
                                      (remove name globals
                                              :key #'first
                                              :test-not #'eq))))))
    (let ((names (remove-duplicates (mapcar #'first globals))))
      `(chain *object
              (assign *globals
                      (create
                       ,@(loop :for sym :in names
                            :for indexes := (indexes sym)
                            :for name := (string-upcase sym)
                            :append `(,name
                                      (api-call new-var ,name ,@indexes)))))))))

(walker:deftransform globals qspvar (&rest var)
  (pushnew var *globals* :test #'equal)
  (walker:walk-continue))

(walker:deftransform globals local (var &rest expr)
  (declare (ignore var))
  (walker:walk 'globals expr))

(defpsmacro create-locals (locals)
  (when locals
    `(progn
       (var locals (create
                    ,@(loop :for (sym index) :in locals
                         :for name := (string-upcase sym)
                         :append `(,name (api-call new-var ,name))))))))

;; locations, blocks, and acts all have their own locals namespace
(walker:deftransform-stop locals qspblock)
(walker:deftransform-stop locals act)

(walker:deftransform locals local (var &optional expr)
  (declare (ignore expr))
  (pushnew (rest var) *locals* :test #'equal)
  nil)

;; index types:
;; literal number
;; literal string
;; variable number
;; variable string
;; expression (may be possible to determine if it's a string or a number)

(defun $-var-p (sym)
  (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))

(defun literal-string-p (form)
  (and (listp form)
       (= 2 (length form))
       (eq 'str (first form))
       (stringp (second form))))

(defun variable-number-p (form)
  (and (listp form)
       (eq 'qspvar (first form))
       (not ($-var-p (second form)))))

(defun variable-string-p (form)
  (and (listp form)
       (eq 'qspvar (first form))
       ($-var-p (second form))))

(walker:deftransform apply-vars set (var expr)
  (destructuring-bind (qspvar name index)
      var
    (declare (ignore qspvar))
    (setf name (string-upcase name))
    (let ((slot `(getprop
                  ,(if (member name *locals* :key #'first)
                       'locals '*globals)
                  ,name))
          (index (walker:walk 'apply-vars index))
          (value (walker:walk 'apply-vars expr)))
      (cond
        ((member name api:*serv-vars* :test #'equalp)
         `(api:set-serv-var ,name ,index ,value))
        ((null index)
         `(chain (elt ,slot) (push ,value)))
        ((or (numberp index)
             (variable-number-p index))
         `(setf (elt ,slot ,index) ,value))
        ((or (literal-string-p index)
             (variable-string-p index))
         `(api:set-str-element ,slot ,index ,value))
        (t
         `(api:set-any-element ,slot ,index ,value))))))

(walker:deftransform apply-vars local (var &optional expr)
                     ;; TODO: var can't be a service variable
  (when expr
    (walker:walk 'apply-vars (list 'set var expr))))

(walker:deftransform apply-vars qspvar (name index)
  (let ((slot `(getprop
                ,(if (member name *locals* :key #'first) 'locals '*globals)
                ,(string-upcase name))))
    (cond
      ((null index)
       `(elt ,slot (1- (length ,slot))))
      ((or (numberp index)
           (variable-number-p index))
       `(elt ,slot ,(walker:walk-continue index)))
      ((or (literal-string-p index)
           (variable-string-p index))
       `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
      (t
       `(get-element ,slot ,(walker:walk-continue index))))))

(walker:deftransform apply-vars qspblock (&rest block)
  (declare (ignore block))
  (walker:whole))
(walker:deftransform apply-vars act (&rest block)
  (declare (ignore block))
  (walker:whole))
(walker:deftransform apply-vars qspfor (var from to step body)
  (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))

;;; 3expr

(defpsmacro <> (op1 op2)
  `(not (equal ,op1 ,op2)))

(defpsmacro qspmod (&rest ops)
  (case (length ops)
    (1 (first ops))
    (2 `(mod ,@ops))
    (t `(mod ,(first ops) (qspmod ,@(rest ops))))))

;;; 4code

(defpsmacro exec (&body body)
  (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))

;;; 5arrays

;;; 6str

(defpsmacro & (&rest args)
  `(chain "" (concat ,@args)))

;;; 7if

(defpsmacro qspcond (&rest clauses)
  `(cond ,@(loop :for clause :in clauses
              :for f := (if (eq 'txt2web::else (first clause))
                            't
                            (first clause))
              :collect (list f
                             `(tagbody
                                 ,@(rest clause))))))

;;; 8sub

;;; 9jump
;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels

(defpsmacro jump (target)
  `(return-from label-body ,(string-upcase (second target))))

(defpsmacro tagbody (&body body)
  (let ((create-locals (if (eq (caar body) 'create-locals)
                           (list (car body))))
        (void (if (equal (car (last body)) '(void))
                  '((void)))))
    (when create-locals
      (setf body (cdr body)))
    (when void
      (setf body (butlast body)))
    (let ((funcs (list nil "_nil")))
      (dolist (form body)
        (cond ((keywordp form)
               (setf (first funcs) (reverse (first funcs)))
               (push (string-upcase form) funcs)
               (push nil funcs))
              (t
               (push form (first funcs)))))
      (setf (first funcs) (reverse (first funcs)))
      (setf funcs (reverse funcs))
      `(progn
         ,@create-locals
         ,(if (= 2 (length funcs))
              `(progn
                 ,@body)
              `(progn
                 (tagbody-blocks ,funcs)
                 (loop
                    :for _nextblock
                      := :_nil
                    :then (await (funcall (getprop _labels _nextblock)))
                    :while _nextblock)))
         ,@void))))

(defvar *current-label*)
(defvar *has-jump-back*)
(walker:deftransform optimize-jump jump (target)
  (cond ((string= (string-upcase (second target)) *current-label*)
         (setf *has-jump-back* t)
         '(continue))
        (t
         (walker:walk-continue))))

(defpsmacro tagbody-blocks (funcs)
  `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
              :append `((@ _labels ,label)
                        (async-lambda ()
                          (block label-body
                            (tagbody-block-body ,label ,code
                                                ,(first rest-labels))))))))

(defpsmacro tagbody-block-body (label code next-label)
  (let ((*current-label* label)
        (*has-jump-back* nil))
    (let ((code (walker:walk 'optimize-jump code)))
      (if *has-jump-back*
          `(progn
             (loop :do (progn
                         ,@code
                         (break)))
             ,@(if next-label
                   (list next-label)
                   nil))
          `(progn
             ,@code
             ,@(if next-label
                   (list next-label)
                   nil))))))

(defpsmacro exit ()
  '(return-from nil (values)))

;;; 10dynamic

(defpsmacro qspblock (&body body)
  `(locals-block
    ,@body))

(defpsmacro qsp-lambda (&body body)
  `(async-lambda (args)
     (label-block ()
       ,@body)))

;;; 11main

(defpsmacro act (name img &body body)
  `(api-call add-act ,name ,img
             (locals-block
               ,@body)))

;;; 12aux

;;; 13diag

;;; 14act

;;; 15objs

;;; 16menu

;;; 17sound

;;; 18img

;;; 19input

;;; 20time

;;; 21local

;;; 22loop

(defpsmacro qsploop (init cond step &body body)
  `(progn
     ,init
     (loop :while ,cond
           :do (progn
                 ,@body
                 ,step))))

;; Transform because it creates a (set ...) hence it has to be processed
;; before the apply-vars transform. And macros are processed after all
;; the transforms
(walker:deftransform for-transform qspfor (var from to step &rest body)
  `(loop :for i :from ,from :to ,to :by ,step
      :do (set ,var i)
      :do (block nil
            ,@(walker:walk-continue body))))