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 ;; Utility functions
  32
  33 (defun ez-decode-signed-byte (b)
  34   (lsh b ))
  35
  36 ;; Memory
  37
  38 (defvar ez-memory nil
  39   "Memory of z-machine.")
  40
  41 (defvar ez-version nil)
  42
  43 (defvar ez-start-pc nil)
  44 (defvar ez-himem-base nil)
  45 (defvar ez-dict-addr nil)
  46 (defvar ez-objtab-addr nil)
  47 (defvar ez-abbrevtab-addr nil)
  48 (defvar ez-globalvartab-addr nil)
  49
  50 (defun ez-mem-ref-byte (addr)
  51   (aref ez-memory addr))
  52
  53 (defun ez-mem-set-byte (addr val)
  54   (aset ez-memory addr val))
  55
  56 (defun ez-mem-ref-word (addr)
  57   (+ (* 256 (aref ez-memory addr))
  58      (aref ez-memory (+ addr 1))))
  59
  60 (defun ez-mem-set-word (addr val)
  61   (let ((byte-high (/ val 256))
  62         (byte-low (mod val 256)))
  63     (aset ez-memory addr byte-high)
  64     (aset ez-memory (+ addr 1) byte-low)))
  65
  66 (defun ez-parse-header ()
  67   (setq ez-version (ez-mem-ref-byte #x0))
  68   (setq ez-himem-addr (ez-mem-ref-word #x4))
  69   (setq ez-start-pc (ez-mem-ref-word #x6))
  70   (setq ez-dict-base (ez-mem-ref-word #x8))
  71   (setq ez-objtab-addr (ez-mem-ref-word #xA))
  72   (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
  73   (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))
  74
  75 (defun ez-load-file (filename)
  76   "Load story file into memory."
  77   (with-temp-buffer
  78     (insert-file-contents-literally filename)
  79     (setq ez-memory (encode-coding-string (buffer-string) 'raw-text))))
  80
  81 ;; Global variables
  82
  83 (defun ez-get-global-var (gvar)
  84   (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr))))
  85
  86 (defun ez-set-global-var (gvar val)
  87   (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val))
  88
  89 ;; Object tree
  90
  91 (defun ez-make-obj (&optional name attribs props parent first-child next-sibling)
  92     (list name attribs props parent first-child next-sibling))
  93
  94 (defun ez-obj-name (obj) (elt obj 0))
  95 (defun ez-obj-attribs (obj) (elt obj 1))
  96 (defun ez-obj-props (obj) (elt obj 2))
  97 (defun ez-obj-parent (obj) (elt obj 3))
  98 (defun ez-obj-first-child (obj) (elt obj 4))
  99 (defun ez-obj-next-sibling (obj) (elt obj 5))
 100
 101 (defvar ez-property-defaults nil)
 102
 103 (defun ez-load-property-defaults ()
 104   (setq ez-property-defaults (make-vector 31 0))
 105   (dotimes (i 31)
 106     (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
 107
 108 (defun ez-get-obj (obj-id)
 109   (let ((addr (+ ez-objtab-addr
 110                  (* 2 31)
 111                  (* 9 (- obj-id 1)))))
 112     (list
 113      obj-id
 114      (ez-mem-ref-byte (+ addr 4))
 115      (ez-mem-ref-byte (+ addr 5))
 116      (ez-mem-ref-byte (+ addr 6))
 117      (ez-mem-ref-word (+ addr 7))
 118      (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
 119        (if (> (ez-mem-ref-byte plist-addr) 0)
 120            (ez-get-zstring (+ 1 plist-addr))
 121          "")))))
 122
 123
 124 ;; Z-strings
 125
 126 (defvar ez-zstring-alphabets
 127   ;                1    1    2    2    3
 128   ;      0    5    0    5    0    5    0
 129   (list "      abcdefghijklmnopqrstuvwxyz"
 130         "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 131         "       \n0123456789.,!?_#'\"/\\-:()")
 132   "Alphabets used by V3")
 133
 134 (defun ez-parse-zstring-word (word)
 135   (list (lsh word -15)
 136         (logand (lsh word -10) #b11111)
 137         (logand (lsh word -5) #b11111)
 138         (logand word #b11111)))
 139
 140 (defun ez-get-zstring-chars (base-addr)
 141   (let ((addr base-addr)
 142         (chars nil)
 143         (not-done t))
 144     (while not-done
 145       (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
 146         (setq chars (append chars (cdr components)))
 147         (setq addr (+ addr 2))
 148         (when (= (car components) 1)
 149           (setq not-done nil))))
 150     chars))
 151
 152 (defun ez-get-zstring (base-addr)
 153   (let ((chars (ez-get-zstring-chars base-addr))
 154         (cur 0)
 155         (lock 0)
 156         (abbrev-char nil)
 157         (s ""))
 158     (dolist (char chars)
 159       (cond
 160        (abbrev-char
 161         (let ((abbrev-addr
 162                (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
 163                                         (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
 164           (setq s (concat s (ez-get-zstring abbrev-addr))))
 165         (setq abbrev-char nil))
 166        ((memq char '(1 2 3)) ;Abbreviation
 167         (setq abbrev-char char))
 168        ((= char 4)
 169         (setq cur (mod (+ cur 1) 2)))
 170        ((= char 5)
 171         (setq cur (mod (+ 2 (- cur 1)) 2)))
 172        (t
 173         (setq s (concat s (substring (elt ez-zstring-alphabets cur)
 174                                      char (+ char 1))))
 175         (setq cur lock))))
 176     s))
 177
 178
 179 ;; Call stack
 180
 181 (defvar ez-call-stack nil)
 182
 183 (defun ez-make-call-stack-frame (pc &optional call-method)
 184   (list pc
 185         nil
 186         (make-vector 15 0)
 187         call-method))
 188
 189 (defun ez-add-call-stack-frame (pc &optional call-method)
 190   (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
 191
 192 (defun ez-pop-call-stack-frame ()
 193   (pop ez-call-stack))
 194
 195 (defun ez-routine-stack ()
 196   (elt (car ez-call-stack) 1))
 197
 198 (defun ez-routine-stack-push (val)
 199   (let ((frame (car ez-call-stack)))
 200     (setf (elt frame 1) (cons val (elt frame 1)))))
 201
 202 (defun ez-routine-stack-pop ()
 203   (let* ((frame (car ez-call-stack))
 204          (rs-head (car (elt frame 1))))
 205     (setf (elt frame 1) (cdr (elt frame 1)))
 206     rs-head))
 207
 208 (defun ez-get-local-var (lvar)
 209   (let ((frame (car ez-call-stack)))
 210     (aref (elt frame 2) (- lvar 1))))
 211
 212 (defun ez-set-local-var (lvar val)
 213   (let ((frame (car ez-call-stack)))
 214     (aset (elt frame 2) (- lvar 1) val)))
 215
 216 (defun ez-get-pc ()
 217   (caar ez-call-stack))
 218
 219 (defun ez-set-pc (new-pc)
 220   (setf (car (car ez-call-stack)) new-pc))
 221
 222 (defun ez-increment-pc (inc)
 223   (ez-set-pc (+ (ez-get-pc) inc)))
 224
 225 (defun ez-read-pc-byte-and-inc ()
 226   (let ((res (ez-mem-ref-byte (ez-get-pc))))
 227     (ez-increment-pc 1)
 228     res))
 229
 230 (defun ez-read-pc-word-and-inc ()
 231   (let ((res (ez-mem-ref-word (ez-get-pc))))
 232     (ez-increment-pc 2)
 233     res))
 234
 235 ;; Instruction execution
 236
 237 (defun ez-get-var (var)
 238   (cond
 239    ((= var 0)
 240     (ez-routine-stack-pop))
 241    ((< var 16)
 242     (ez-get-local-var var))
 243    (t
 244     (ez-get-global-var (- var 16)))))
 245
 246 (defun ez-set-var (var val)
 247   (cond
 248    ((= var 0)
 249     (ez-routine-stack-push val))
 250    ((< var 16)
 251     (ez-set-local-var var val))
 252    (t
 253     (ez-set-global-var (- var 16) val))))
 254
 255 (defun ez-read-pc-var-and-inc ()
 256   (ez-get-var (ez-read-pc-byte-and-inc)))
 257
 258 (defun ez-execute-instr ()
 259   (let ((instr-pc (ez-get-pc))
 260         (opbyte (ez-read-pc-byte-and-inc))
 261         (optype)
 262         (opcode nil)
 263         (operands))
 264     (cond
 265      ((<= #x0 opbyte #x1f)
 266       (setq optype '2op
 267             opcode opbyte
 268             operands (list (ez-read-pc-byte-and-inc)
 269                            (ez-read-pc-byte-and-inc))
 270             operand-types '(b b)))
 271      ((<= #x20 opbyte #x3F)
 272       (setq optype '2op
 273             opcode (- opbyte #x20)
 274             operands (list (ez-read-pc-byte-and-inc)
 275                            (ez-read-pc-var-and-inc))
 276             operand-types '(b w)))
 277      ((<= #x40 opbyte #x5F)
 278       (setq optype '2op
 279             opcode (- opbyte #x40)
 280             operands (list (ez-read-pc-var-and-inc)
 281                            (ez-read-pc-byte-and-inc))
 282             operand-types '(w b)))
 283      ((<= #x60 opbyte #x7F)
 284       (setq optype '2op
 285             opcode (- opbyte #x60)
 286             operands (list (ez-read-pc-var-and-inc)
 287                            (ez-read-pc-var-and-inc))
 288             operand-types '(w w)))
 289      ((<= #x80 opbyte #x8F)
 290       (setq optype '1op
 291             opcode (- opbyte #x80)
 292             operands (list (ez-read-pc-word-and-inc))
 293             operand-types '(w)))
 294      ((<= #x90 opbyte #x9F)
 295       (setq optype '1op
 296             opcode (- opbyte #x90)
 297             operands (list (ez-read-pc-byte-and-inc))
 298             operand-types '(b)))
 299      ((<= #xA0 opbyte #xAF)
 300       (setq optype '1op
 301             opcode (- opbyte #xa0)
 302             operands (list (ez-read-pc-var-and-inc))
 303             operand-types '(w)))
 304      ((<= #xB0 opbyte #xBF)
 305       (setq optype '0op
 306             opcode (- opbyte #xb0)))
 307      ((<= #xC0 opbyte #xDF)
 308       (error "Unsupported op" opbyte))
 309      ((<= #xE0 opbyte #xFF)
 310       (setq optype 'var
 311             opcode (- opbyte #xe0))
 312       (let ((operands-and-types (ez-read-var-operands-and-inc)))
 313         (setq operands (car operands-and-types)
 314               operand-types (cdr operands-and-types)))))
 315     (let ((table-row (assoc (list optype opcode) ez-op-table)))
 316       (unless table-row
 317         (error "Unsupported op" optype opcode))
 318       (let ((mnemonic (elt table-row 1)))
 319         (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
 320                  instr-pc optype opcode mnemonic operands))
 321       (funcall (elt table-row 2) operands operand-types))))
 322
 323 (defun ez-read-var-operands-and-inc ()
 324   (let* ((type-byte (ez-read-pc-byte-and-inc))
 325          (bleh (message (binformat type-byte)))
 326          (types (let ((type1 (lsh type-byte -6)))
 327                   (if (= type1 #b11)
 328                       nil
 329                     (cons type1
 330                           (let ((type2 (lsh (logand #b110000 type-byte) -4)))
 331                             (if (= type2 #b11)
 332                                 nil
 333                               (cons type2
 334                                     (let ((type3 (lsh (logand #b1100 type-byte) -2)))
 335                                       (if (= type3 #b11)
 336                                           nil
 337                                         (cons type3
 338                                               (let ((type4 (logand #b11)))
 339                                                 (if (= type4 #b11)
 340                                                     nil
 341                                                   (list type4)))))))))))))
 342          (operands nil))
 343     (cons
 344      (mapcar
 345       (lambda (type)
 346         (cond
 347          ((= type 0) (ez-read-pc-word-and-inc))
 348          ((= type 1) (ez-read-pc-byte-and-inc))
 349          ((= type 2) (ez-read-pc-var-and-inc))))
 350       types)
 351      (mapcar
 352       (lambda (type)
 353         (if (= type 1)
 354             'b
 355           'w))
 356       types)))))
 357
 358 (defvar ez-op-table
 359   '(((2op #x14) add ez-op-add)
 360     ((2op #x15) sub ez-op-sub)
 361     ((2op #x16) mul ez-op-mul)
 362     ((2op #x17) div ez-op-div)
 363     ((2op #x18) mod ez-op-mod)
 364     ((var #x00) call_fv ez-op-callf)))
 365
 366 (defun ez-op-add (operands operand-types)
 367   (let ((a (car operands))
 368         (b (cadr operands)))
 369     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ a b) #x10000))))
 370
 371 (defun ez-op-sub (operands operand-types)
 372   (let ((a (car operands))
 373         (b (cadr operands)))
 374     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ (- a b) #x10000) #x10000))))
 375
 376 (defun ez-op-mul (a b)
 377   (let ((a (car operands))
 378         (b (cadr operands)))
 379     (ez-set-var (ez-read-pc-byte-and-inc) (mod (* a b) #x10000))))
 380
 381 (defun ez-op-div (a b))
 382
 383 (defun ez-op-mod (a b))
 384
 385 (defun ez-op-callf (operands operand-types)
 386   (let* ((raddr (car operands))
 387          (call-operands (cdr operands))
 388          (r (* 2 raddr))
 389          (L (ez-mem-ref-byte r))
 390          (n (length call-operands))
 391          (new-pc (+ r 1 (* L 2))))
 392     (ez-add-call-stack-frame new-pc)
 393     (dotimes (i L)
 394       (if (< i n)
 395           (ez-set-local-var (+ i 1) (elt call-operands i))
 396         (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
 397   t)
 398
 399 ;; Main
 400
 401 (defun ez-run (filename)
 402   (ez-load-file filename)
 403   (ez-parse-header)
 404   (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 405
 406   (while (ez-execute-inst)))
 407
 408 ;; Scratch
 409
 410 (ez-load-file "zork1.z3")
 411 (ez-parse-header)
 412 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 413 (ez-execute-instr)
 414 ez-call-stack
 415
 416 (defun binformat (n &optional s)
 417   (unless s
 418     (setq s ""))
 419   (let ((d (/ n 2))
 420         (new-s (concat (number-to-string (mod n 2)) s)))
 421     (if (= d 0)
 422         new-s
 423       (binformat d new-s))))
 424
 425
 426
 427 ;;; ez.el ends here