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