;;; ez.el --- Emacs Z-machine

;; Copyright (C) 2021 Tim Vaughan

;; Author: Tim Vaughan <timv@ughan.xyz>
;; Created: 13 Oct 2021
;; Version: 1.0
;; Keywords: game
;; Homepage: http://thelambdalab.xyz/ez
;; Package-Requires: ((emacs "26"))

;; This file is not part of GNU Emacs.

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this file.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; Character set tables

;; Memory

(defvar ez-memory nil
  "Memory of z-machine.")

(defvar ez-version nil)

(defvar ez-start-pc nil)
(defvar ez-himem-base nil)
(defvar ez-dict-addr nil)
(defvar ez-objtab-addr nil)
(defvar ez-abbrevtab-addr nil)
(defvar ez-globalvartab-addr nil)

(defun ez-mem-ref-byte (addr)
  (aref ez-memory addr))

(defun ez-mem-set-byte (addr val)
  (aset ez-memory addr val))

(defun ez-mem-ref-word (addr)
  (+ (* 256 (aref ez-memory addr))
     (aref ez-memory (+ addr 1))))

(defun ez-mem-set-word (addr val)
  (let ((byte-high (/ val 256))
        (byte-low (mod val 256)))
    (aset ez-memory addr byte-high)
    (aset ez-memory (+ addr 1) byte-low)))

(defun ez-parse-header ()
  (setq ez-version (ez-mem-ref-byte #x0))
  (setq ez-himem-addr (ez-mem-ref-word #x4))
  (setq ez-start-pc (ez-mem-ref-word #x6))
  (setq ez-dict-base (ez-mem-ref-word #x8))
  (setq ez-objtab-addr (ez-mem-ref-word #xA))
  (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
  (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))

(defun ez-load-file (filename)
  "Load story file into memory."
  (with-temp-buffer
    (insert-file-contents-literally filename)
    (setq ez-memory (encode-coding-string (buffer-string) 'raw-text))))

;; Global variables

(defun ez-get-global-var (gvar)
  (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr))))

(defun ez-set-global-var (gvar val)
  (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val))

;; Object tree

(defun ez-make-obj (&optional name attribs props parent first-child next-sibling)
    (list name attribs props parent first-child next-sibling))

(defun ez-obj-name (obj) (elt obj 0))
(defun ez-obj-attribs (obj) (elt obj 1))
(defun ez-obj-props (obj) (elt obj 2))
(defun ez-obj-parent (obj) (elt obj 3))
(defun ez-obj-first-child (obj) (elt obj 4))
(defun ez-obj-next-sibling (obj) (elt obj 5))

(defvar ez-property-defaults nil)

(defun ez-load-property-defaults ()
  (setq ez-property-defaults (make-vector 31 0))
  (dotimes (i 31)
    (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))

(defun ez-get-obj (obj-id)
  (let ((addr (+ ez-objtab-addr
                 (* 2 31)
                 (* 9 (- obj-id 1)))))
    (list
     obj-id
     (ez-mem-ref-byte (+ addr 4))
     (ez-mem-ref-byte (+ addr 5))
     (ez-mem-ref-byte (+ addr 6))
     (ez-mem-ref-word (+ addr 7))
     (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
       (if (> (ez-mem-ref-byte plist-addr) 0)
           (ez-get-zstring (+ 1 plist-addr))
         "")))))


;; Z-strings

(defvar ez-zstring-alphabets
  ;                1    1    2    2    3
  ;      0    5    0    5    0    5    0
  (list "      abcdefghijklmnopqrstuvwxyz"
        "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        "       \n0123456789.,!?_#'\"/\\-:()")
  "Alphabets used by V3")

(defun ez-parse-zstring-word (word)
  (list (lsh word -15)
        (logand (lsh word -10) #b11111)
        (logand (lsh word -5) #b11111)
        (logand word #b11111)))

(defun ez-get-zstring-chars (base-addr)
  (let ((addr base-addr)
        (chars nil)
        (not-done t))
    (while not-done
      (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
        (setq chars (append chars (cdr components)))
        (setq addr (+ addr 2))
        (when (= (car components) 1)
          (setq not-done nil))))
    chars))

(defun ez-get-zstring (base-addr)
  (let ((chars (ez-get-zstring-chars base-addr))
        (cur 0)
        (lock 0)
        (abbrev-char nil)
        (s ""))
    (dolist (char chars)
      (cond
       (abbrev-char
        (let ((abbrev-addr
               (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
                                        (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
          (setq s (concat s (ez-get-zstring abbrev-addr))))
        (setq abbrev-char nil))
       ((memq char '(1 2 3)) ;Abbreviation
        (setq abbrev-char char))
       ((= char 4)
        (setq cur (mod (+ cur 1) 2)))
       ((= char 5)
        (setq cur (mod (+ 2 (- cur 1)) 2)))
       (t 
        (setq s (concat s (substring (elt ez-zstring-alphabets cur)
                                     char (+ char 1))))
        (setq cur lock))))
    s))


;; Call stack

(defvar ez-call-stack nil)

(defun ez-make-call-stack-frame (pc &optional call-method)
  (list pc
        nil
        (make-vector 15 0)
        call-method))

(defun ez-add-call-stack-frame (pc &optional call-method)
  (push (ez-make-call-stack-frame pc call-method) ez-call-stack))

(defun ez-pop-call-stack-frame ()
  (pop ez-call-stack))

(defun ez-routine-stack ()
  (elt (car ez-call-stack) 1))

(defun ez-routine-stack-push (val)
  (let ((frame (car ez-call-stack)))
    (setf (elt frame 1) (cons val (elt frame 1)))))

(defun ez-routine-stack-pop ()
  (let* ((frame (car ez-call-stack))
         (rs-head (car (elt frame 1))))
    (setf (elt frame 1) (cdr (elt frame 1)))
    rs-head))

(defun ez-get-local-var (lvar)
  (let ((frame (car ez-call-stack)))
    (aref (elt frame 2) (- lvar 1))))

(defun ez-set-local-var (lvar val)
  (let ((frame (car ez-call-stack)))
    (aset (elt frame 2) (- lvar 1) val)))

(defun ez-get-pc ()
  (caar ez-call-stack))

(defun ez-set-pc (new-pc)
  (setf (car (car ez-call-stack)) new-pc))

(defun ez-increment-pc (inc)
  (ez-set-pc (+ (ez-get-pc) inc)))

(defun ez-read-pc-byte-and-inc ()
  (let ((res (ez-mem-ref-byte (ez-get-pc))))
    (ez-increment-pc 1)
    res))

(defun ez-read-pc-word-and-inc ()
  (let ((res (ez-mem-ref-word (ez-get-pc))))
    (ez-increment-pc 2)
    res))

;; Instruction execution

(defun ez-get-var (var)
  (cond
   ((= var 0)
    (ez-routine-stack-pop))
   ((< var 16)
    (ez-get-local-var var))
   (t
    (ez-get-global-var (- var 16)))))

(defun ez-set-var (var val)
  (cond
   ((= var 0)
    (ez-routine-stack-push val))
   ((< var 16)
    (ez-set-local-var var val))
   (t
    (ez-set-global-var (- var 16) val))))

(defun ez-read-pc-var-and-inc ()
  (ez-get-var (ez-read-pc-byte-and-inc)))

(defun ez-execute-instr ()
  (let ((opbyte (ez-read-pc-byte-and-inc))
        (optype)
        (opcode nil)
        (operands))
    (cond
     ((<= #x0 opbyte #x1f)
      (setq optype '2op
            opcode opbyte
            operands (list (ez-read-pc-byte-and-inc)
                            (ez-read-pc-byte-and-inc))))
     ((<= #x20 opbyte #x3F)
      (setq optype '2op
            opcode (- opbyte #x20)
            operands (list (ez-read-pc-byte-and-inc)
                           (ez-read-pc-var-and-inc))))
     ((<= #x40 opbyte #x5F)
      (setq optype '2op
            opcode (- opbyte #x40)
            operands (list (ez-read-pc-var-and-inc)
                           (ez-read-pc-byte-and-inc))))
     ((<= #x60 opbyte #x7F)
      (setq optype '2op
            opcode (- opbyte #x60)
            operands (list (ez-read-pc-var-and-inc)
                           (ez-read-pc-var-and-inc))))
     ((<= #x80 opbyte #x8F)
      (setq optype '1op
            opcode (- opbyte #x80)
            operands (list (ez-read-pc-word-and-inc))))
     ((<= #x90 opbyte #x9F)
      (setq optype '1op
            opcode (- opbyte #x90)
            operands (list (ez-read-pc-byte-and-inc))))
     ((<= #xA0 opbyte #xAF)
      (setq optype '1op
            opcode (- opbyte #xa0)
            operands (list (ez-read-pc-var-and-inc))))
     ((<= #xB0 opbyte #xBF)
      (setq optype '0op
            opcode (- opbyte #xb0)))
     ((<= #xC0 opbyte #xDF)
      (error "Unsupported op" opbyte))
     ((<= #xE0 opbyte #xFF)
      (setq optype 'var
            opcode (- opbyte #xe0)
            operands (ez-read-var-operands-and-inc))))
    (let ((table-row (assoc (list optype opcode) ez-op-table)))
      (unless table-row
        (error "Unsupported op" optype opcode))
      (let ((mnemonic (elt table-row 1)))
        (message "Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
                 optype opcode mnemonic operands))
      (apply (elt table-row 2) operands))))

(defun ez-read-var-operands-and-inc ()
  (let* ((type-byte (ez-read-pc-byte-and-inc))
         (bleh (message (binformat type-byte)))
         (types (let ((type1 (lsh type-byte -6)))
                  (if (= type1 #b11)
                      nil
                    (cons type1
                          (let ((type2 (lsh (logand #b110000 type-byte) -4)))
                            (if (= type2 #b11)
                                nil
                              (cons type2
                                    (let ((type3 (lsh (logand #b1100 type-byte) -2)))
                                      (if (= type3 #b11)
                                          nil
                                        (cons type3
                                              (let ((type4 (logand #b11)))
                                                (if (= type4 #b11)
                                                    nil
                                                  (list type4)))))))))))))
         (operands nil))
    (mapcar
     (lambda (type)
       (cond
        ((= type 0) (ez-read-pc-word-and-inc))
        ((= type 1) (ez-read-pc-byte-and-inc))
        ((= type 2) (ez-read-pc-var-and-inc))))
     types)))

(defvar ez-op-table
  '(((var #x0) call_fv ez-op-callf)))

(defun ez-op-callf (raddr &rest operands)
  (let* ((r (* 2 raddr))
         (L (ez-mem-ref-byte r))
         (n (length operands))
         (new-pc (+ r 1 (* L 2))))
    (ez-add-call-stack-frame new-pc)
    (dotimes (i L)
      (if (< i n)
          (ez-set-local-var (+ i 1) (elt operands i))
        (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
  t)

;; Main

(defun ez-run (filename)
  (ez-load-file filename)
  (ez-parse-header)
  (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))

  (while (ez-execute-inst)))

;; Scratch

(ez-load-file "zork1.z3")
(ez-parse-header)
(setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
(ez-execute-instr)
ez-call-stack

(defun binformat (n &optional s)
  (unless s
    (setq s ""))
  (let ((d (/ n 2))
        (new-s (concat (number-to-string (mod n 2)) s)))
    (if (= d 0)
        new-s
      (binformat d new-s))))



;;; ez.el ends here