ez.el

   1 ;;; ez.el --- Emacs Z-machine
   2
   3 ;; Copyright (C) 2021 Tim Vaughan
   4
   5 ;; Author: Tim Vaughan <timv@ughan.xyz>
   6 ;; Created: 13 Oct 2021
   7 ;; Version: 1.0
   8 ;; Keywords: game
   9 ;; Homepage: http://thelambdalab.xyz/ez
  10 ;; Package-Requires: ((emacs "26"))
  11
  12 ;; This file is not part of GNU Emacs.
  13
  14 ;; This program is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this file.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 ;; Character set tables
  32
  33 ;; Memory
  34
  35 (defvar ez-memory nil
  36   "Memory of z-machine.")
  37
  38 (defvar ez-version nil)
  39
  40 (defvar ez-start-pc nil)
  41 (defvar ez-himem-base nil)
  42 (defvar ez-dict-addr nil)
  43 (defvar ez-objtab-addr nil)
  44 (defvar ez-abbrevtab-addr nil)
  45 (defvar ez-globalvartab-addr nil)
  46
  47 (defun ez-mem-ref-byte (addr)
  48   (aref ez-memory addr))
  49
  50 (defun ez-mem-set-byte (addr val)
  51   (aset ez-memory addr val))
  52
  53 (defun ez-mem-ref-word (addr)
  54   (+ (* 256 (aref ez-memory addr))
  55      (aref ez-memory (+ addr 1))))
  56
  57 (defun ez-mem-set-word (addr val)
  58   (let ((byte-high (/ val 256))
  59         (byte-low (mod val 256)))
  60     (aset ez-memory addr byte-high)
  61     (aset ez-memory (+ addr 1) byte-low)))
  62
  63 (defun ez-parse-header ()
  64   (setq ez-version (ez-mem-ref-byte #x0))
  65   (setq ez-himem-addr (ez-mem-ref-word #x4))
  66   (setq ez-start-pc (ez-mem-ref-word #x6))
  67   (setq ez-dict-base (ez-mem-ref-word #x8))
  68   (setq ez-objtab-addr (ez-mem-ref-word #xA))
  69   (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
  70   (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))
  71
  72 (defun ez-load-file (filename)
  73   "Load story file into memory."
  74   (with-temp-buffer
  75     (insert-file-contents-literally filename)
  76     (setq ez-memory (encode-coding-string (buffer-string) 'raw-text))))
  77
  78 ;; Global variables
  79
  80 (defun ez-get-global-var (gvar)
  81   (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr))))
  82
  83 (defun ez-set-global-var (gvar val)
  84   (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val))
  85
  86 ;; Object tree
  87
  88 (defun ez-make-obj (&optional name attribs props parent first-child next-sibling)
  89     (list name attribs props parent first-child next-sibling))
  90
  91 (defun ez-obj-name (obj) (elt obj 0))
  92 (defun ez-obj-attribs (obj) (elt obj 1))
  93 (defun ez-obj-props (obj) (elt obj 2))
  94 (defun ez-obj-parent (obj) (elt obj 3))
  95 (defun ez-obj-first-child (obj) (elt obj 4))
  96 (defun ez-obj-next-sibling (obj) (elt obj 5))
  97
  98 (defvar ez-property-defaults nil)
  99
 100 (defun ez-load-property-defaults ()
 101   (setq ez-property-defaults (make-vector 31 0))
 102   (dotimes (i 31)
 103     (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
 104
 105 (defun ez-get-obj (obj-id)
 106   (let ((addr (+ ez-objtab-addr
 107                  (* 2 31)
 108                  (* 9 (- obj-id 1)))))
 109     (list
 110      obj-id
 111      (ez-mem-ref-byte (+ addr 4))
 112      (ez-mem-ref-byte (+ addr 5))
 113      (ez-mem-ref-byte (+ addr 6))
 114      (ez-mem-ref-word (+ addr 7))
 115      (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
 116        (if (> (ez-mem-ref-byte plist-addr) 0)
 117            (ez-get-zstring (+ 1 plist-addr))
 118          "")))))
 119
 120
 121 ;; Z-strings
 122
 123 (defvar ez-zstring-alphabets
 124   ;                1    1    2    2    3
 125   ;      0    5    0    5    0    5    0
 126   (list "      abcdefghijklmnopqrstuvwxyz"
 127         "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 128         "       \n0123456789.,!?_#'\"/\\-:()")
 129   "Alphabets used by V3")
 130
 131 (defun ez-parse-zstring-word (word)
 132   (list (lsh word -15)
 133         (logand (lsh word -10) #b11111)
 134         (logand (lsh word -5) #b11111)
 135         (logand word #b11111)))
 136
 137 (defun ez-get-zstring-chars (base-addr)
 138   (let ((addr base-addr)
 139         (chars nil)
 140         (not-done t))
 141     (while not-done
 142       (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
 143         (setq chars (append chars (cdr components)))
 144         (setq addr (+ addr 2))
 145         (when (= (car components) 1)
 146           (setq not-done nil))))
 147     chars))
 148
 149 (defun ez-get-zstring (base-addr)
 150   (let ((chars (ez-get-zstring-chars base-addr))
 151         (cur 0)
 152         (lock 0)
 153         (abbrev-char nil)
 154         (s ""))
 155     (dolist (char chars)
 156       (cond
 157        (abbrev-char
 158         (let ((abbrev-addr
 159                (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
 160                                         (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
 161           (setq s (concat s (ez-get-zstring abbrev-addr))))
 162         (setq abbrev-char nil))
 163        ((memq char '(1 2 3)) ;Abbreviation
 164         (setq abbrev-char char))
 165        ((= char 4)
 166         (setq cur (mod (+ cur 1) 2)))
 167        ((= char 5)
 168         (setq cur (mod (+ 2 (- cur 1)) 2)))
 169        (t
 170         (setq s (concat s (substring (elt ez-zstring-alphabets cur)
 171                                      char (+ char 1))))
 172         (setq cur lock))))
 173     s))
 174
 175
 176 ;; Call stack
 177
 178 (defvar ez-call-stack nil)
 179
 180 (defun ez-make-call-stack-frame (pc &optional call-method)
 181   (list pc
 182         nil
 183         (make-vector 15 0)
 184         call-method))
 185
 186 (defun ez-add-call-stack-frame (pc &optional call-method)
 187   (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
 188
 189 (defun ez-pop-call-stack-frame ()
 190   (pop ez-call-stack))
 191
 192 (defun ez-routine-stack ()
 193   (elt (car ez-call-stack) 1))
 194
 195 (defun ez-routine-stack-push (val)
 196   (let ((frame (car ez-call-stack)))
 197     (setf (elt frame 1) (cons val (elt frame 1)))))
 198
 199 (defun ez-routine-stack-pop ()
 200   (let* ((frame (car ez-call-stack))
 201          (rs-head (car (elt frame 1))))
 202     (setf (elt frame 1) (cdr (elt frame 1)))
 203     rs-head))
 204
 205 (defun ez-get-local-var (lvar)
 206   (let ((frame (car ez-call-stack)))
 207     (aref (elt frame 2) (- lvar 1))))
 208
 209 (defun ez-set-local-var (lvar val)
 210   (let ((frame (car ez-call-stack)))
 211     (aset (elt frame 2) (- lvar 1) val)))
 212
 213 (defun ez-get-pc ()
 214   (caar ez-call-stack))
 215
 216 (defun ez-set-pc (new-pc)
 217   (setf (car (car ez-call-stack)) new-pc))
 218
 219 (defun ez-increment-pc (inc)
 220   (ez-set-pc (+ (ez-get-pc) inc)))
 221
 222 (defun ez-read-pc-byte-and-inc ()
 223   (let ((res (ez-mem-ref-byte (ez-get-pc))))
 224     (ez-increment-pc 1)
 225     res))
 226
 227 (defun ez-read-pc-word-and-inc ()
 228   (let ((res (ez-mem-ref-word (ez-get-pc))))
 229     (ez-increment-pc 2)
 230     res))
 231
 232 ;; Instruction execution
 233
 234 (defun ez-get-var (var)
 235   (cond
 236    ((= var 0)
 237     (ez-routine-stack-pop))
 238    ((< var 16)
 239     (ez-get-local-var var))
 240    (t
 241     (ez-get-global-var (- var 16)))))
 242
 243 (defun ez-set-var (var val)
 244   (cond
 245    ((= var 0)
 246     (ez-routine-stack-push val))
 247    ((< var 16)
 248     (ez-set-local-var var val))
 249    (t
 250     (ez-set-global-var (- var 16) val))))
 251
 252 (defun ez-read-pc-var-and-inc ()
 253   (ez-get-var (ez-read-pc-byte-and-inc)))
 254
 255 (defun ez-execute-instr ()
 256   (let ((opbyte (ez-read-pc-byte-and-inc))
 257         (optype)
 258         (opcode nil)
 259         (operands))
 260     (cond
 261      ((<= #x0 opbyte #x1f)
 262       (setq optype '2op
 263             opcode opbyte
 264             operands (list (ez-read-pc-byte-and-inc)
 265                             (ez-read-pc-byte-and-inc))))
 266      ((<= #x20 opbyte #x3F)
 267       (setq optype '2op
 268             opcode (- opbyte #x20)
 269             operands (list (ez-read-pc-byte-and-inc)
 270                            (ez-read-pc-var-and-inc))))
 271      ((<= #x40 opbyte #x5F)
 272       (setq optype '2op
 273             opcode (- opbyte #x40)
 274             operands (list (ez-read-pc-var-and-inc)
 275                            (ez-read-pc-byte-and-inc))))
 276      ((<= #x60 opbyte #x7F)
 277       (setq optype '2op
 278             opcode (- opbyte #x60)
 279             operands (list (ez-read-pc-var-and-inc)
 280                            (ez-read-pc-var-and-inc))))
 281      ((<= #x80 opbyte #x8F)
 282       (setq optype '1op
 283             opcode (- opbyte #x80)
 284             operands (list (ez-read-pc-word-and-inc))))
 285      ((<= #x90 opbyte #x9F)
 286       (setq optype '1op
 287             opcode (- opbyte #x90)
 288             operands (list (ez-read-pc-byte-and-inc))))
 289      ((<= #xA0 opbyte #xAF)
 290       (setq optype '1op
 291             opcode (- opbyte #xa0)
 292             operands (list (ez-read-pc-var-and-inc))))
 293      ((<= #xB0 opbyte #xBF)
 294       (setq optype '0op
 295             opcode (- opbyte #xb0)))
 296      ((<= #xC0 opbyte #xDF)
 297       (error "Unsupported op" opbyte))
 298      ((<= #xE0 opbyte #xFF)
 299       (setq optype 'var
 300             opcode (- opbyte #xe0)
 301             operands (ez-read-var-operands-and-inc))))
 302     (let ((table-row (assoc (list optype opcode) ez-op-table)))
 303       (unless table-row
 304         (error "Unsupported op" optype opcode))
 305       (let ((mnemonic (elt table-row 1)))
 306         (message "Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
 307                  optype opcode mnemonic operands))
 308       (apply (elt table-row 2) operands))))
 309
 310 (defun ez-read-var-operands-and-inc ()
 311   (let* ((type-byte (ez-read-pc-byte-and-inc))
 312          (bleh (message (binformat type-byte)))
 313          (types (let ((type1 (lsh type-byte -6)))
 314                   (if (= type1 #b11)
 315                       nil
 316                     (cons type1
 317                           (let ((type2 (lsh (logand #b110000 type-byte) -4)))
 318                             (if (= type2 #b11)
 319                                 nil
 320                               (cons type2
 321                                     (let ((type3 (lsh (logand #b1100 type-byte) -2)))
 322                                       (if (= type3 #b11)
 323                                           nil
 324                                         (cons type3
 325                                               (let ((type4 (logand #b11)))
 326                                                 (if (= type4 #b11)
 327                                                     nil
 328                                                   (list type4)))))))))))))
 329          (operands nil))
 330     (mapcar
 331      (lambda (type)
 332        (cond
 333         ((= type 0) (ez-read-pc-word-and-inc))
 334         ((= type 1) (ez-read-pc-byte-and-inc))
 335         ((= type 2) (ez-read-pc-var-and-inc))))
 336      types)))
 337
 338 (defvar ez-op-table
 339   '(((var #x0) call_fv ez-op-callf)))
 340
 341 (defun ez-op-callf (raddr &rest operands)
 342   (let* ((r (* 2 raddr))
 343          (L (ez-mem-ref-byte r))
 344          (n (length operands))
 345          (new-pc (+ r 1 (* L 2))))
 346     (ez-add-call-stack-frame new-pc)
 347     (dotimes (i L)
 348       (if (< i n)
 349           (ez-set-local-var (+ i 1) (elt operands i))
 350         (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
 351   t)
 352
 353 ;; Main
 354
 355 (defun ez-run (filename)
 356   (ez-load-file filename)
 357   (ez-parse-header)
 358   (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 359
 360   (while (ez-execute-inst)))
 361
 362 ;; Scratch
 363
 364 (ez-load-file "zork1.z3")
 365 (ez-parse-header)
 366 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 367 (ez-execute-instr)
 368 ez-call-stack
 369
 370 (defun binformat (n &optional s)
 371   (unless s
 372     (setq s ""))
 373   (let ((d (/ n 2))
 374         (new-s (concat (number-to-string (mod n 2)) s)))
 375     (if (= d 0)
 376         new-s
 377       (binformat d new-s))))
 378
 379
 380
 381 ;;; ez.el ends here