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-bits (n nbits)
  34   (if (= 0 (lsh n (- 1 nbits)))
  35       n
  36     (- n (lsh 1 nbits))))
  37
  38 (defun ez-decode-signed-byte (b)
  39   (ez-decode-signed-bits b 8))
  40
  41 (defun ez-decode-signed-word (w)
  42   (ez-decode-signed-bits w 16))
  43
  44 (defun binformat (n &optional s)
  45   (unless s
  46     (setq s ""))
  47   (let ((d (/ n 2))
  48         (new-s (concat (number-to-string (mod n 2)) s)))
  49     (if (= d 0)
  50         new-s
  51       (binformat d new-s))))
  52
  53 ;; Memory
  54
  55 (defvar ez-memory nil
  56   "Memory of z-machine.")
  57
  58 (defvar ez-version nil)
  59
  60 (defvar ez-start-pc nil)
  61 (defvar ez-himem-base nil)
  62 (defvar ez-dict-addr nil)
  63 (defvar ez-objtab-addr nil)
  64 (defvar ez-abbrevtab-addr nil)
  65 (defvar ez-globalvartab-addr nil)
  66
  67 (defun ez-mem-ref-byte (addr)
  68   (aref ez-memory addr))
  69
  70 (defun ez-mem-set-byte (addr val)
  71   (aset ez-memory addr val))
  72
  73 (defun ez-mem-ref-word (addr)
  74   (+ (* 256 (aref ez-memory addr))
  75      (aref ez-memory (+ addr 1))))
  76
  77 (defun ez-mem-set-word (addr val)
  78   (let ((byte-high (/ val 256))
  79         (byte-low (mod val 256)))
  80     (aset ez-memory addr byte-high)
  81     (aset ez-memory (+ addr 1) byte-low)))
  82
  83 (defun ez-parse-header ()
  84   (setq ez-version (ez-mem-ref-byte #x0))
  85   (setq ez-himem-addr (ez-mem-ref-word #x4))
  86   (setq ez-start-pc (ez-mem-ref-word #x6))
  87   (setq ez-dict-base (ez-mem-ref-word #x8))
  88   (setq ez-objtab-addr (ez-mem-ref-word #xA))
  89   (setq ez-globalvartab-addr (ez-mem-ref-word #xC))
  90   (setq ez-abbrevtab-addr (ez-mem-ref-word #x18)))
  91
  92 (defun ez-load-file (filename)
  93   "Load story file into memory."
  94   (with-temp-buffer
  95     (insert-file-contents-literally filename)
  96     (setq ez-memory (encode-coding-string (buffer-string) 'raw-text))))
  97
  98 ;; Global variables
  99
 100 (defun ez-get-global-var (gvar)
 101   (ez-mem-ref-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr))))
 102
 103 (defun ez-set-global-var (gvar val)
 104   (ez-mem-set-word (+ (* 2 gvar) (ez-mem-ref-word ez-globalvartab-addr)) val))
 105
 106 ;; Object tree
 107
 108 (defun ez-make-obj (&optional name attribs props parent first-child next-sibling)
 109     (list name attribs props parent first-child next-sibling))
 110
 111 (defun ez-obj-name (obj) (elt obj 0))
 112 (defun ez-obj-attribs (obj) (elt obj 1))
 113 (defun ez-obj-props (obj) (elt obj 2))
 114 (defun ez-obj-parent (obj) (elt obj 3))
 115 (defun ez-obj-first-child (obj) (elt obj 4))
 116 (defun ez-obj-next-sibling (obj) (elt obj 5))
 117
 118 (defvar ez-property-defaults nil)
 119
 120 (defun ez-load-property-defaults ()
 121   (setq ez-property-defaults (make-vector 31 0))
 122   (dotimes (i 31)
 123     (aset ez-property-defaults i (aref ez-memory (+ ez-objtab-addr (* 2 i))))))
 124
 125 (defun ez-get-obj (obj-id)
 126   (let ((addr (+ ez-objtab-addr
 127                  (* 2 31)
 128                  (* 9 (- obj-id 1)))))
 129     (list
 130      obj-id
 131      (ez-mem-ref-byte (+ addr 4))
 132      (ez-mem-ref-byte (+ addr 5))
 133      (ez-mem-ref-byte (+ addr 6))
 134      (ez-mem-ref-word (+ addr 7))
 135      (let ((plist-addr (ez-mem-ref-word (+ addr 7))))
 136        (if (> (ez-mem-ref-byte plist-addr) 0)
 137            (ez-get-zstring (+ 1 plist-addr))
 138          "")))))
 139
 140
 141 ;; Z-strings
 142
 143 (defvar ez-zstring-alphabets
 144   ;                1    1    2    2    3
 145   ;      0    5    0    5    0    5    0
 146   (list "      abcdefghijklmnopqrstuvwxyz"
 147         "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 148         "       \n0123456789.,!?_#'\"/\\-:()")
 149   "Alphabets used by V3")
 150
 151 (defun ez-parse-zstring-word (word)
 152   (list (lsh word -15)
 153         (logand (lsh word -10) #b11111)
 154         (logand (lsh word -5) #b11111)
 155         (logand word #b11111)))
 156
 157 (defun ez-get-zstring-chars (base-addr)
 158   (let ((addr base-addr)
 159         (chars nil)
 160         (not-done t))
 161     (while not-done
 162       (let ((components (ez-parse-zstring-word (ez-mem-ref-word addr))))
 163         (setq chars (append chars (cdr components)))
 164         (setq addr (+ addr 2))
 165         (when (= (car components) 1)
 166           (setq not-done nil))))
 167     chars))
 168
 169 (defun ez-get-zstring (base-addr)
 170   (let ((chars (ez-get-zstring-chars base-addr))
 171         (cur 0)
 172         (lock 0)
 173         (abbrev-char nil)
 174         (s ""))
 175     (dolist (char chars)
 176       (cond
 177        (abbrev-char
 178         (let ((abbrev-addr
 179                (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr
 180                                         (* 2 (+ (* (- abbrev-char 1) 32) char)))))))
 181           (setq s (concat s (ez-get-zstring abbrev-addr))))
 182         (setq abbrev-char nil))
 183        ((memq char '(1 2 3)) ;Abbreviation
 184         (setq abbrev-char char))
 185        ((= char 4)
 186         (setq cur (mod (+ cur 1) 2)))
 187        ((= char 5)
 188         (setq cur (mod (+ 2 (- cur 1)) 2)))
 189        (t
 190         (setq s (concat s (substring (elt ez-zstring-alphabets cur)
 191                                      char (+ char 1))))
 192         (setq cur lock))))
 193     s))
 194
 195
 196 ;; Call stack
 197
 198 (defvar ez-call-stack nil)
 199
 200 (defun ez-make-call-stack-frame (pc &optional call-method)
 201   (list pc
 202         nil
 203         (make-vector 15 0)
 204         call-method))
 205
 206 (defun ez-add-call-stack-frame (pc &optional call-method)
 207   (push (ez-make-call-stack-frame pc call-method) ez-call-stack))
 208
 209 (defun ez-pop-call-stack-frame ()
 210   (pop ez-call-stack))
 211
 212 (defun ez-routine-stack ()
 213   (elt (car ez-call-stack) 1))
 214
 215 (defun ez-routine-stack-push (val)
 216   (let ((frame (car ez-call-stack)))
 217     (setf (elt frame 1) (cons val (elt frame 1)))))
 218
 219 (defun ez-routine-stack-pop ()
 220   (let* ((frame (car ez-call-stack))
 221          (rs-head (car (elt frame 1))))
 222     (setf (elt frame 1) (cdr (elt frame 1)))
 223     rs-head))
 224
 225 (defun ez-get-local-var (lvar)
 226   (let ((frame (car ez-call-stack)))
 227     (aref (elt frame 2) (- lvar 1))))
 228
 229 (defun ez-set-local-var (lvar val)
 230   (let ((frame (car ez-call-stack)))
 231     (aset (elt frame 2) (- lvar 1) val)))
 232
 233 (defun ez-get-pc ()
 234   (caar ez-call-stack))
 235
 236 (defun ez-set-pc (new-pc)
 237   (setf (car (car ez-call-stack)) new-pc))
 238
 239 (defun ez-increment-pc (inc)
 240   (ez-set-pc (+ (ez-get-pc) inc)))
 241
 242 (defun ez-read-pc-byte-and-inc ()
 243   (let ((res (ez-mem-ref-byte (ez-get-pc))))
 244     (ez-increment-pc 1)
 245     res))
 246
 247 (defun ez-read-pc-word-and-inc ()
 248   (let ((res (ez-mem-ref-word (ez-get-pc))))
 249     (ez-increment-pc 2)
 250     res))
 251
 252 ;; Instruction execution
 253
 254 (defun ez-get-var (var)
 255   (cond
 256    ((= var 0)
 257     (ez-routine-stack-pop))
 258    ((< var 16)
 259     (ez-get-local-var var))
 260    (t
 261     (ez-get-global-var (- var 16)))))
 262
 263 (defun ez-set-var (var val)
 264   (cond
 265    ((= var 0)
 266     (ez-routine-stack-push val))
 267    ((< var 16)
 268     (ez-set-local-var var val))
 269    (t
 270     (ez-set-global-var (- var 16) val))))
 271
 272 (defun ez-read-pc-var-and-inc ()
 273   (ez-get-var (ez-read-pc-byte-and-inc)))
 274
 275 (defun ez-execute-instr ()
 276   (let ((instr-pc (ez-get-pc))
 277         (opbyte (ez-read-pc-byte-and-inc))
 278         (optype)
 279         (opcode nil)
 280         (operands))
 281     (cond
 282      ((<= #x0 opbyte #x1f)
 283       (setq optype '2op
 284             opcode opbyte
 285             operands (list (ez-read-pc-byte-and-inc)
 286                            (ez-read-pc-byte-and-inc))
 287             operand-types '(b b)))
 288      ((<= #x20 opbyte #x3F)
 289       (setq optype '2op
 290             opcode (- opbyte #x20)
 291             operands (list (ez-read-pc-byte-and-inc)
 292                            (ez-read-pc-var-and-inc))
 293             operand-types '(b w)))
 294      ((<= #x40 opbyte #x5F)
 295       (setq optype '2op
 296             opcode (- opbyte #x40)
 297             operands (list (ez-read-pc-var-and-inc)
 298                            (ez-read-pc-byte-and-inc))
 299             operand-types '(w b)))
 300      ((<= #x60 opbyte #x7F)
 301       (setq optype '2op
 302             opcode (- opbyte #x60)
 303             operands (list (ez-read-pc-var-and-inc)
 304                            (ez-read-pc-var-and-inc))
 305             operand-types '(w w)))
 306      ((<= #x80 opbyte #x8F)
 307       (setq optype '1op
 308             opcode (- opbyte #x80)
 309             operands (list (ez-read-pc-word-and-inc))
 310             operand-types '(w)))
 311      ((<= #x90 opbyte #x9F)
 312       (setq optype '1op
 313             opcode (- opbyte #x90)
 314             operands (list (ez-read-pc-byte-and-inc))
 315             operand-types '(b)))
 316      ((<= #xA0 opbyte #xAF)
 317       (setq optype '1op
 318             opcode (- opbyte #xa0)
 319             operands (list (ez-read-pc-var-and-inc))
 320             operand-types '(w)))
 321      ((<= #xB0 opbyte #xBF)
 322       (setq optype '0op
 323             opcode (- opbyte #xb0)))
 324      ((<= #xC0 opbyte #xDF)
 325       (error "Unsupported op" opbyte))
 326      ((<= #xE0 opbyte #xFF)
 327       (setq optype 'var
 328             opcode (- opbyte #xe0))
 329       (let ((operands-and-types (ez-read-var-operands-and-inc)))
 330         (setq operands (car operands-and-types)
 331               operand-types (cdr operands-and-types)))))
 332     (let ((table-row (assoc (list optype opcode) ez-op-table)))
 333       (unless table-row
 334         (error "Unsupported op" optype opcode))
 335       (let ((mnemonic (elt table-row 1)))
 336         (message "PC:%x Optype:%s Opcode:%x Mnemonic:%s Operands:%s"
 337                  instr-pc optype opcode mnemonic operands))
 338       (funcall (elt table-row 2) operands operand-types))))
 339
 340 (defun ez-read-var-operands-and-inc ()
 341   (let* ((type-byte (ez-read-pc-byte-and-inc))
 342          (bleh (message (binformat type-byte)))
 343          (types (let ((type1 (lsh type-byte -6)))
 344                   (if (= type1 #b11)
 345                       nil
 346                     (cons type1
 347                           (let ((type2 (lsh (logand #b110000 type-byte) -4)))
 348                             (if (= type2 #b11)
 349                                 nil
 350                               (cons type2
 351                                     (let ((type3 (lsh (logand #b1100 type-byte) -2)))
 352                                       (if (= type3 #b11)
 353                                           nil
 354                                         (cons type3
 355                                               (let ((type4 (logand #b11)))
 356                                                 (if (= type4 #b11)
 357                                                     nil
 358                                                   (list type4)))))))))))))
 359          (operands nil))
 360     (cons
 361      (mapcar
 362       (lambda (type)
 363         (cond
 364          ((= type 0) (ez-read-pc-word-and-inc))
 365          ((= type 1) (ez-read-pc-byte-and-inc))
 366          ((= type 2) (ez-read-pc-var-and-inc))))
 367       types)
 368      (mapcar
 369       (lambda (type)
 370         (if (= type 1)
 371             'b
 372           'w))
 373       types))))
 374
 375 ;; Branches
 376
 377 (defun ez-do-branch (branch)
 378   (let* ((branch-byte (ez-read-pc-byte-and-inc))
 379          (invert (= 0 (logand branch-byte #b10000000)))
 380          (single-byte (= 1 (logand branch-byte #b01000000)))
 381          (offset
 382           (if single-byte
 383               (logand branch-byte #b00111111)
 384             (let ((pos (= (logand branch-byte #b00100000) 0))
 385                   (val (+ (* 256 (logand branch-byte #b00011111))
 386                           (ez-read-pc-byte-and-inc))))
 387               (if pos
 388                   val
 389                 (- val 8192))))))
 390     (cond
 391      ((= offset 0)
 392       (ez-op-rfalse))
 393      ((= offset 1)
 394       (ez-op-rtrue))
 395      (t
 396       (ez-set-pc (+ (ez-get-pc) offset -2))))))
 397
 398 ;; Operations
 399
 400 (defvar ez-op-table
 401   '(((0op #x00) rtrue ez-op-rtrue)
 402     ((0op #x01) rfalse ez-op-rfalse)
 403     ((1op #x00) jz ez-op-jz)
 404     ((1op #x0B) ret ez-op-ret)
 405     ((1op #x0C) jump ez-op-jump)
 406     ((2op #x0D) store ez-op-store)
 407     ((1op #x0E) load ez-op-load)
 408     ((var #x01) storew ez-op-storew)
 409     ((2op #x01) je ez-op-je)
 410     ((2op #x08) or ez-op-or)
 411     ((2op #x09) and ez-op-and)
 412     ((2op #x14) add ez-op-add)
 413     ((2op #x15) sub ez-op-sub)
 414     ((2op #x16) mul ez-op-mul)
 415     ((2op #x17) div ez-op-div)
 416     ((2op #x18) mod ez-op-mod)
 417     ((var #x00) call_fv ez-op-callf)))
 418
 419 (defun ez-op-ret (operands &optional operand-types)
 420   (let ((retval (car operands)))
 421     (ez-pop-call-stack-frame)
 422     (ez-set-var (ez-read-pc-byte-and-inc) retval))
 423   t)
 424
 425 (defun ez-op-rtrue (&optional operands operand-types)
 426   (ez-op-ret (list 1)))
 427
 428 (defun ez-op-rfalse (&optional operands operand-types)
 429   (ez-op-ret (list 0)))
 430
 431 (defun ez-op-jz (operands operand-types)
 432   (ez-do-branch (= (car operands) 0))
 433   t)
 434
 435 (defun ez-op-je (operands operand-types)
 436   (ez-do-branch (memq (car operands) (cdr operands)))
 437   t)
 438
 439 (defun ez-op-jump (operands operand-types)
 440   (let ((offset (if (eq (car operand-types) 'b)
 441                     (ez-decode-signed-byte (car operands))
 442                   (ez-decode-signed-word (car operands)))))
 443     (ez-set-pc (+ (ez-get-pc) offset -2)))
 444   t)
 445
 446 (defun ez-op-store (operands operand-types)
 447   (let ((var (car operands))
 448         (a (cadr operands)))
 449     (ez-set-var var a))
 450   t)
 451
 452 (defun ez-op-load (operands operand-types)
 453   (let ((var (car operands)))
 454     (ez-set-var (ez-read-pc-byte-and-inc) (ez-get-var var)))
 455   t)
 456
 457 (defun ez-op-storew (operands operand-types)
 458   (let ((baddr (car operands))
 459         (n (cadr operands))
 460         (a (caddr operands)))
 461     (ez-mem-set-word (+ baddr (* 2 n)) a))
 462   t)
 463
 464 (defun ez-op-and (operands operand-types)
 465   (let ((a (car operands))
 466         (b (cadr operands)))
 467     (ez-set-var (ez-read-pc-byte-and-inc) (logand a b)))
 468   t)
 469
 470 (defun ez-op-or (operands operand-types)
 471   (let ((a (car operands))
 472         (b (cadr operands)))
 473     (ez-set-var (ez-read-pc-byte-and-inc) (logior a b)))
 474   t)
 475
 476 (defun ez-op-add (operands operand-types)
 477   (let ((a (car operands))
 478         (b (cadr operands)))
 479     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ a b) #x10000)))
 480   t)
 481
 482 (defun ez-op-sub (operands operand-types)
 483   (let ((a (car operands))
 484         (b (cadr operands)))
 485     (ez-set-var (ez-read-pc-byte-and-inc) (mod (+ (- a b) #x10000) #x10000)))
 486   t)
 487
 488 (defun ez-op-mul (a b)
 489   (let ((a (car operands))
 490         (b (cadr operands)))
 491     (ez-set-var (ez-read-pc-byte-and-inc) (mod (* a b) #x10000)))
 492   t)
 493
 494 (defun ez-op-div (a b)
 495   (error "Not implemented"))
 496
 497 (defun ez-op-mod (a b)
 498   (error "Not implemented"))
 499
 500 (defun ez-op-callf (operands operand-types)
 501   (let* ((raddr (car operands))
 502          (call-operands (cdr operands))
 503          (r (* 2 raddr))
 504          (L (ez-mem-ref-byte r))
 505          (n (length call-operands))
 506          (new-pc (+ r 1 (* L 2))))
 507     (ez-add-call-stack-frame new-pc)
 508     (dotimes (i L)
 509       (if (< i n)
 510           (ez-set-local-var (+ i 1) (elt call-operands i))
 511         (ez-set-local-var (+ i 1) (ez-mem-ref-word (+ r 1 (* 2 i)))))))
 512   t)
 513
 514 ;; Main
 515
 516 (defun ez-run (filename)
 517   (ez-load-file filename)
 518   (ez-parse-header)
 519   (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 520
 521   (while (ez-execute-inst)))
 522
 523 ;; Scratch
 524
 525 (ez-load-file "zork1.z3")
 526 (ez-parse-header)
 527 (setq ez-call-stack (list (ez-make-call-stack-frame ez-start-pc)))
 528 (ez-execute-instr)
 529
 530 (binformat #x97)
 531 "10010111"
 532
 533
 534 ez-call-stack
 535 ((28281 nil [33807 0 180 47872 0 0 0 0 0 0 0 0 ...] nil) (22022 nil [33807 65535 0 0 0 0 0 0 0 0 0 0 ...] nil) (20715 nil [0 0 0 0 0 0 0 0 0 0 0 0 ...] nil))
 536
 537 ((22049 nil [33807 0 180 47872 0 0 0 0 0 0 0 0 ...] nil) (22022 nil [33807 65535 0 0 0 0 0 0 0 0 0 0 ...] nil) (20715 nil [0 0 0 0 0 0 0 0 0 0 0 0 ...] nil))
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550 ;;; ez.el ends here