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