; malyon.el --- mode to execute z code files version 3, 5, 8
;; Maintainer: Peter Ilberg <
[email protected]>
;; (I am unable to continue supporting malyon.el. Please send me an
;; email if you are interested in taking over the project. Thanks.)
;; Copyright (C) 1999-2011 Peter Ilberg
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;; Credits:
;; The author would like to thank the following people for reporting
;; bugs, testing, suggesting and/or contributing improvements:
;; Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko
;;; Commentary:
;; This package provides a basic interpreter for version 3, 5, 8 z code
;; story files as generated by Inform (C) Graham Nelson and Infocom.
;; If you encounter a bug please send a report to Peter Ilberg at
;;
[email protected]. Thank you!
;; To play a story file simple type M-x malyon and enter the path to the
;; story file. If anything goes wrong and you want to manually clean
;; up type M-x malyon-quit. In addition, you can switch back to a game in
;; progress by typing M-x malyon-restore.
;; A note on the format of saved game states:
;; As of version 1.0, Malyon supports the quetzal file format for saved
;; games. Support for this format required changes to several internal
;; data structures (stack frames and catch-throw) that are incompatible
;; with the old implementation. Unfortunately, the old file format for
;; saved games cannot be converted into quetzal.
;; For backwards compatibility, however, Malyon still supports the old
;; file format. And you can continue to play your old game states.
;; Because of the incompatibility of the two file formats, Malyon now
;; runs, as follows, in either of two modes: quetzal and compatibility.
;; - in quetzal mode, game states are saved in quetzal format
;; - in compatibility mode, games states are saved in the old format
;; - loading a game state in quetzal format switches to quetzal mode
;; - loading an old game state switches to compatibility mode
;; - quetzal mode is the default setting
;; In other words, Malyon will only use the old file format if you've
;; restored a game state saved in the old file format.
;; Enjoy!
;;; Code:
;; global variables - moved here to appease the byte-code compiler
;; story file information
(defvar malyon-story-file-name nil
"The name of the story file being executed.")
(defvar malyon-story-file nil
"The story file which is currently being run.")
(defvar malyon-story-version nil
"The story file version.")
(defvar malyon-supported-versions '(3 5 8)
"A list of supported story file versions.")
;; status and transcript buffers
(defvar malyon-transcript-buffer nil
"The main transcript buffer of the story file execution.")
(defvar malyon-transcript-buffer-buffered nil
"Is output in the transcript buffer buffered?")
(defvar malyon-status-buffer nil
"The status bar buffer of the story file execution.")
(defvar malyon-status-buffer-lines nil
"The number of lines in the status bar buffer.")
(defvar malyon-status-buffer-delayed-split nil
"If the number of lines in the status buffer is reduced,
the window configuration is not changed immediately. It
is changed after the next turn (read or read_char).")
(defvar malyon-status-buffer-point nil
"The point location in the status bar buffer.")
(defvar malyon-max-column 72
"Maximum column for text display.")
;; window management
(defvar malyon-window-configuration nil
"The current window configuration of the malyon interpreter.")
(defvar malyon-current-window nil
"The currently active window for text output.")
;; z machine registers
(defvar malyon-stack nil
"The stack of the z machine.")
(defvar malyon-stack-pointer nil
"The stack pointer of the z machine.")
(defvar malyon-frame-pointer nil
"The frame pointer of the z machine.")
(defvar malyon-instruction-pointer nil
"The instruction pointer of the z machine.")
;; game file related global variables
(defvar malyon-score-game nil
"A flag indicating whether this story uses score or time.")
(defvar malyon-packed-multiplier nil
"The amount by which packed addresses are multiplied to get byte
addresses.")
(defvar malyon-global-variables nil
"A pointer to the global variable section in the story file.")
(defvar malyon-abbreviations nil
"A pointer to the abbreviations in the story file.")
(defvar malyon-alphabet nil
"The z machine's text alphabet.")
(defvar malyon-whitespace nil
"A string of whitespace characters recognized by the interpreter.")
;; object tables
(defvar malyon-object-table nil
"A pointer to the object table in the story file.")
(defvar malyon-object-table-entry-size nil
"The size of one entry in the object table.")
(defvar malyon-object-properties nil
"The number of properties per object minus one.")
(defvar malyon-object-property-offset nil
"The byte offset of the properties table in the object.")
;; dictionaries
(defvar malyon-dictionary nil
"A pointer to the dictionary of the story file.")
(defvar malyon-dictionary-entry-length nil
"The length of a dictionary entry.")
(defvar malyon-dictionary-num-entries nil
"The number of dictionary entries.")
(defvar malyon-dictionary-entries nil
"A pointer to the first dictionary entry.")
(defvar malyon-dictionary-word-length nil
"The length of a dictionary word.")
;; game state information
(defvar malyon-game-state-restart nil
"The machine state for implementing restart.")
(defvar malyon-game-state-undo nil
"The machine state for implementing undo.")
(defvar malyon-game-state-quetzal t
"Store game state information for quetzal.")
;; various
(defvar malyon-current-face nil
"The current face in which to display text.")
(defvar malyon-last-cursor-position-after-input nil
"The last cursor position after reading input from the keyboard.")
;; interactive functions
(defun malyon (file-name)
"Major mode for playing z3/5/8 story files.
This mode allows execution of version 3, 5, 8 z code story files."
(interactive "fStory file name: ")
(if malyon-story-file
(message "You are already playing a game.")
(if (not (string-match ".*\.z[358]$" file-name))
(message "%s is not a version 3, 5, or 8 story file." file-name)
(condition-case nil
(malyon-load-story-file file-name)
(error
(malyon-fatal-error "loading of story file failed.")))
(setq malyon-story-version (aref malyon-story-file 0))
(cond ((memq malyon-story-version malyon-supported-versions)
(condition-case nil
(malyon-initialize)
(error
(malyon-fatal-error "initialization of interpreter failed.")))
(malyon-interpreter))
(t
(message "%s is not a version 3, 5, or 8 story file." file-name)
(malyon-cleanup))))))
(defun malyon-restore ()
"Restore the save window configuration for the interpreter."
(interactive)
(condition-case nil
(progn
(malyon-restore-window-configuration)
(malyon-adjust-transcript))
(error
(malyon-fatal-error "restoring window configuration failed."))))
(defun malyon-quit ()
"Exit the malyon interpreter."
(interactive)
(if malyon-story-file
(progn
(malyon-restore)
(if (malyon-yes-or-no-p-minibuf "Do you really want to quit? ")
(malyon-cleanup)))))
(defun malyon-mode ()
"This mode provides a basic interpreter for version 3, 5, 8 z code
story files as generated by Inform (C) Graham Nelson and Infocom.
Note that this package is by no means complete and bug free.
If you encounter a bug please send a report to Peter Ilberg at
[email protected]. Thank you!
To play a story file simple type M-x malyon and enter the path to the
story file. If anything goes wrong and you want to manually clean
up type M-x malyon-quit. In addition, you can switch back to a game in
progress by typing M-x malyon-restore.
The author would like to thank the following people for reporting
bugs, testing, suggesting and/or contributing improvements:
Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko"
(message "Use M-x malyon if you want to play a zcode game."))
;; compatibility functions for GNU emacs
(if (fboundp 'cadr)
(defalias 'malyon-cadr 'cadr)
(defun malyon-cadr (list)
"Take the cadr of the list."
(car (cdr list))))
(if (fboundp 'caddr)
(defalias 'malyon-caddr 'caddr)
(defun malyon-caddr (list)
"Take the caddr of the list."
(car (cdr (cdr list)))))
(if (fboundp 'cdddr)
(defalias 'malyon-cdddr 'cdddr)
(defun malyon-cdddr (list)
"Take the cdddr of the list."
(cdr (cdr (cdr list)))))
(if (fboundp 'char-before)
(defalias 'malyon-char-before 'char-before)
(defun malyon-char-before ()
"Return the character before the point."
(char-after (- (point) 1))))
(if (fboundp 'char-to-int)
(defalias 'malyon-char-to-int 'char-to-int)
(defun malyon-char-to-int (c)
"Convert a character into an integer."
c))
(if (fboundp 'characterp)
(defalias 'malyon-characterp 'characterp)
(defun malyon-characterp (x)
"Test for a character."
(and (numberp x) (<= 0 x) (< x 256))))
(defun malyon-disable-multibyte ()
"Disable multibyte support in the current buffer."
(condition-case nil (set-buffer-multibyte nil) (error)))
(defun malyon-erase-buffer (&optional buffer)
"Erase the given buffer."
(save-excursion
(if buffer (set-buffer buffer))
(if (and buffer (eq buffer malyon-transcript-buffer))
(malyon-begin-section)
(erase-buffer))))
(if (fboundp 'int-to-char)
(defalias 'malyon-int-to-char 'int-to-char)
(defun malyon-int-to-char (i)
"Convert an integer into a character."
i))
(if (fboundp 'mapc)
(defalias 'malyon-mapc 'mapc)
(defun malyon-mapc (function list)
"Apply fun to every element of args ignoring the results."
(if (null list)
'()
(funcall function (car list))
(malyon-mapc function (cdr list)))))
(if (fboundp 'mapcan)
(defalias 'malyon-mapcan 'mapcan)
(defun malyon-mapcan (function list)
"Apply fun to every element of args nconc'ing the result."
(if (null list)
'()
(nconc (funcall function (car list))
(malyon-mapcan function (cdr list))))))
; Do not use the built-in conversion via 'multibyte-char-to-unibyte.
(defun malyon-multibyte-char-to-unibyte (char)
"Convert a multibyte character to unibyte."
char)
(defun malyon-point-max (&optional buffer)
"Get the point-max of the given buffer."
(save-excursion
(if buffer (set-buffer buffer))
(point-max)))
(if (fboundp 'redisplay-frame)
(defalias 'malyon-redisplay-frame 'redisplay-frame)
(defun malyon-redisplay-frame (frame &rest ignore)
"Redisplay the given frame."))
(if (fboundp 'remove)
(defalias 'malyon-remove 'remove)
(defun malyon-remove (element list)
"Remove the element from the list."
(cond ((null list)
'())
((eq element (car list))
(malyon-remove element (cdr list)))
((equal element (car list))
(malyon-remove element (cdr list)))
(t
(cons (car list)
(malyon-remove element (cdr list)))))))
(if (fboundp 'set-keymap-name)
(defalias 'malyon-set-keymap-name 'set-keymap-name)
(defun malyon-set-keymap-name (keymap name)
"Set the name of the keymap."))
(if (fboundp 'string-to-list)
(defalias 'malyon-string-to-list 'string-to-list)
(defun malyon-string-to-list (s)
"Convert a string into a list of characters."
(let ((i (- (length s) 1)) (l '()))
(while (<= 0 i)
(setq l (cons (aref s i) l)
i (- i 1)))
l)))
(if (fboundp 'string-to-vector)
(defalias 'malyon-string-to-vector 'string-to-vector)
(defun malyon-string-to-vector (s)
"Convert a string into a vector of characters."
(let* ((i 0) (l (length s)) (v (make-vector l 0)))
(while (< i l)
(aset v i (aref s i))
(setq i (+ 1 i)))
v)))
; Do not use the built-in conversion via 'unibyte-char-to-multibyte.
(defun malyon-unibyte-char-to-multibyte (char)
"Convert a unibyte character to multibyte."
char)
(defun malyon-vector-to-list (v begin end)
"Return a list of elements in v in the range [begin, end)."
(let ((result '()))
(while (< begin end)
(setq result (cons (aref v begin) result))
(setq begin (+ 1 begin)))
(reverse result)))
(if (fboundp 'window-displayed-height)
(defalias 'malyon-window-displayed-height 'window-displayed-height)
(defun malyon-window-displayed-height (&optional window)
"Get the height of the window's displayed region."
(- (window-height) 1)))
(if (fboundp 'yes-or-no-p-minibuf)
(defalias 'malyon-yes-or-no-p-minibuf 'yes-or-no-p-minibuf)
(defun malyon-yes-or-no-p-minibuf (prompt)
"Ask a yes or no question."
(yes-or-no-p prompt)))
;; global variables for the malyon mode
(defvar malyon-syntax-table nil
"Syntax table used while in malyon mode (same as in text-mode).")
(if malyon-syntax-table
'()
(setq malyon-syntax-table (make-syntax-table))
(modify-syntax-entry ?\" ". " malyon-syntax-table)
(modify-syntax-entry ?\\ ". " malyon-syntax-table)
(modify-syntax-entry ?' "w " malyon-syntax-table))
(defvar malyon-keymap-read nil
"Keymap for malyon mode for reading input into a buffer.")
(defvar malyon-history-saved-up nil
"The saved binding for the up arrow key.")
(defvar malyon-history-saved-down nil
"The saved binding for the down arrow key.")
(if malyon-keymap-read
'()
(setq malyon-keymap-read (make-sparse-keymap))
(malyon-set-keymap-name malyon-keymap-read 'malyon-keymap-read)
(setq malyon-history-saved-up (global-key-binding [up]))
(setq malyon-history-saved-down (global-key-binding [down]))
(define-key malyon-keymap-read "\r" 'malyon-end-input)
(define-key malyon-keymap-read [up] 'malyon-history-previous-char)
(define-key malyon-keymap-read [down] 'malyon-history-next-char)
(define-key malyon-keymap-read "\M-p" 'malyon-history-previous-char)
(define-key malyon-keymap-read "\M-n" 'malyon-history-next-char)
(define-key malyon-keymap-read "\C-a" 'malyon-beginning-of-line)
(define-key malyon-keymap-read "\C-w" 'malyon-kill-region)
(define-key malyon-keymap-read "\C-k" 'malyon-kill-line)
(define-key malyon-keymap-read "\M-d" 'malyon-kill-word)
(define-key malyon-keymap-read "\C-y" 'malyon-yank)
(define-key malyon-keymap-read "\M-y" 'malyon-yank-pop)
(define-key malyon-keymap-read "\C-d" 'malyon-delete-char)
(define-key malyon-keymap-read "\d" 'malyon-backward-delete-char)
(define-key malyon-keymap-read [del] 'malyon-delete-char)
(define-key malyon-keymap-read [backspace] 'malyon-backward-delete-char)
(substitute-key-definition (lookup-key (current-global-map) "a")
'malyon-self-insert-command
malyon-keymap-read (current-global-map)))
(defvar malyon-keymap-readchar nil
"Keymap for malyon mode for waiting for input.")
(if malyon-keymap-readchar
'()
(setq malyon-keymap-readchar (make-sparse-keymap))
(malyon-set-keymap-name malyon-keymap-readchar 'malyon-keymap-readchar)
(define-key malyon-keymap-readchar "\r" 'malyon-wait-char)
(substitute-key-definition (lookup-key (current-global-map) "a")
'malyon-wait-char
malyon-keymap-readchar (current-global-map)))
(defvar malyon-keymap-more nil
"Keymap for malyon mode for browsing through text.")
(if malyon-keymap-more
'()
(setq malyon-keymap-more (make-sparse-keymap))
(malyon-set-keymap-name malyon-keymap-more 'malyon-keymap-more)
(define-key malyon-keymap-more "\r" 'malyon-more-char)
(substitute-key-definition (lookup-key (current-global-map) "a")
'malyon-more-char
malyon-keymap-more (current-global-map)))
(defvar malyon-keymap-more-status nil
"Keymap for malyon mode for browsing through the status buffer.")
(if malyon-keymap-more-status
'()
(setq malyon-keymap-more-status (make-sparse-keymap))
(malyon-set-keymap-name malyon-keymap-more-status 'malyon-keymap-more-status)
(define-key malyon-keymap-more-status "\r" 'malyon-more-char-status)
(substitute-key-definition (lookup-key (current-global-map) "a")
'malyon-more-char-status
malyon-keymap-more-status (current-global-map)))
(defvar malyon-faces nil
"An association list of text faces used by the malyon mode.")
(defun malyon-initialize-faces ()
(copy-face 'default 'malyon-face-plain)
(copy-face 'bold 'malyon-face-reverse)
(copy-face 'bold 'malyon-face-bold)
(copy-face 'italic 'malyon-face-italic)
(copy-face 'default 'malyon-face-error)
(set-face-foreground 'malyon-face-error "red")
(setq malyon-faces '((0 . malyon-face-plain)
(1 . malyon-face-reverse)
(2 . malyon-face-bold)
(4 . malyon-face-italic)
(8 . malyon-face-plain))))
(defvar malyon-print-separator nil
"A flag indicating whether to print the * * * separator.")
(defun malyon-begin-section ()
"Print a section divider and begin a new section."
(if malyon-print-separator
(progn
(malyon-mapc 'malyon-putchar-transcript '(?\n ?\n ?* ? ?* ? ?*))
(center-line)
(malyon-mapc 'malyon-putchar-transcript '(?\n ?\n))
(setq malyon-print-separator nil)))
(narrow-to-region (point-max) (point-max)))
(if malyon-whitespace
'()
(setq malyon-whitespace (list (malyon-char-to-int ? )
(malyon-char-to-int ?\t)
(malyon-char-to-int ?\n)
(malyon-char-to-int ?\r))))
;; memory utilities
(defsubst malyon-read-byte (address)
"Read a byte at address in the story file."
(if (<= 0 address)
(aref malyon-story-file address)
(aref malyon-story-file (+ 65536 address))))
(defsubst malyon-store-byte (address value)
"Store a byte at address in the story file."
(if (<= 0 address)
(aset malyon-story-file address (logand 255 value))
(aset malyon-story-file (+ 65536 address) (logand 255 value))))
(defsubst malyon-read-word (address)
"Read a word at address in the story file."
(if (<= 0 address)
(logior (lsh (aref malyon-story-file address) 8)
(aref malyon-story-file (+ 1 address)))
(logior (lsh (aref malyon-story-file (+ 65536 address)) 8)
(aref malyon-story-file (+ 65537 address)))))
(defsubst malyon-store-word (address value)
"Store a word at address in the story file."
(if (<= 0 address)
(progn
(aset malyon-story-file address (logand 255 (lsh value -8)))
(aset malyon-story-file (+ 1 address) (logand 255 value)))
(aset malyon-story-file (+ 65536 address) (logand 255 (lsh value -8)))
(aset malyon-story-file (+ 65537 address) (logand 255 value))))
(defsubst malyon-read-code-byte ()
"Read the next byte at the program counter location."
(setq malyon-instruction-pointer (+ malyon-instruction-pointer 1))
(malyon-read-byte (- malyon-instruction-pointer 1)))
(defsubst malyon-read-code-word ()
"Read the next word at the program counter location."
(setq malyon-instruction-pointer (+ malyon-instruction-pointer 2))
(malyon-read-word (- malyon-instruction-pointer 2)))
(defsubst malyon-pop-stack ()
"Pop a value off the stack."
(if (> 0 malyon-stack-pointer)
(malyon-fatal-error "stack underflow."))
(setq malyon-stack-pointer (- malyon-stack-pointer 1))
(aref malyon-stack (+ malyon-stack-pointer 1)))
(defsubst malyon-read-local-variable (variable)
"Read a local variable."
(aref malyon-stack (+ variable malyon-frame-pointer)))
(defsubst malyon-read-global-variable (variable)
"Read a global variable."
(malyon-read-word (+ malyon-global-variables (* 2 variable))))
(defsubst malyon-read-variable (variable)
"Read a variable."
(cond ((= variable 0) (malyon-pop-stack))
((< variable 16) (malyon-read-local-variable variable))
(t (malyon-read-global-variable (- variable 16)))))
(defsubst malyon-push-stack (value)
"Push a value onto the stack."
(setq malyon-stack-pointer (+ malyon-stack-pointer 1))
(aset malyon-stack malyon-stack-pointer value))
(defsubst malyon-store-local-variable (variable value)
"Store a value in a local variable."
(aset malyon-stack (+ variable malyon-frame-pointer) value))
(defsubst malyon-store-global-variable (variable value)
"Store a value in a global variable."
(malyon-store-word (+ malyon-global-variables (* 2 variable)) value))
(defsubst malyon-store-variable (var value)
"Store the value in a variable."
(setq value (logand 65535 value))
(cond ((= var 0) (malyon-push-stack value))
((< var 16) (malyon-store-local-variable var value))
(t (malyon-store-global-variable (- var 16) value))))
;; list of opcodes
(defvar malyon-opcodes
[malyon-opcode-nop
malyon-opcode-je malyon-opcode-jl
malyon-opcode-jg malyon-opcode-dec-chk
malyon-opcode-inc-chk malyon-opcode-jin
malyon-opcode-test malyon-opcode-or
malyon-opcode-and malyon-opcode-test-attr
malyon-opcode-set-attr malyon-opcode-clear-attr
malyon-opcode-store malyon-opcode-insert-obj
malyon-opcode-loadw malyon-opcode-loadb
malyon-opcode-get-prop malyon-opcode-get-prop-addr
malyon-opcode-get-next-prop malyon-opcode-add
malyon-opcode-sub malyon-opcode-mul
malyon-opcode-div malyon-opcode-mod
malyon-opcode-calls malyon-opcode-calln
malyon-opcode-set-color malyon-opcode-throw
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-je malyon-opcode-jl
malyon-opcode-jg malyon-opcode-dec-chk
malyon-opcode-inc-chk malyon-opcode-jin
malyon-opcode-test malyon-opcode-or
malyon-opcode-and malyon-opcode-test-attr
malyon-opcode-set-attr malyon-opcode-clear-attr
malyon-opcode-store malyon-opcode-insert-obj
malyon-opcode-loadw malyon-opcode-loadb
malyon-opcode-get-prop malyon-opcode-get-prop-addr
malyon-opcode-get-next-prop malyon-opcode-add
malyon-opcode-sub malyon-opcode-mul
malyon-opcode-div malyon-opcode-mod
malyon-opcode-calls malyon-opcode-calln
malyon-opcode-set-color malyon-opcode-throw
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-je malyon-opcode-jl
malyon-opcode-jg malyon-opcode-dec-chk
malyon-opcode-inc-chk malyon-opcode-jin
malyon-opcode-test malyon-opcode-or
malyon-opcode-and malyon-opcode-test-attr
malyon-opcode-set-attr malyon-opcode-clear-attr
malyon-opcode-store malyon-opcode-insert-obj
malyon-opcode-loadw malyon-opcode-loadb
malyon-opcode-get-prop malyon-opcode-get-prop-addr
malyon-opcode-get-next-prop malyon-opcode-add
malyon-opcode-sub malyon-opcode-mul
malyon-opcode-div malyon-opcode-mod
malyon-opcode-calls malyon-opcode-calln
malyon-opcode-set-color malyon-opcode-throw
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-je malyon-opcode-jl
malyon-opcode-jg malyon-opcode-dec-chk
malyon-opcode-inc-chk malyon-opcode-jin
malyon-opcode-test malyon-opcode-or
malyon-opcode-and malyon-opcode-test-attr
malyon-opcode-set-attr malyon-opcode-clear-attr
malyon-opcode-store malyon-opcode-insert-obj
malyon-opcode-loadw malyon-opcode-loadb
malyon-opcode-get-prop malyon-opcode-get-prop-addr
malyon-opcode-get-next-prop malyon-opcode-add
malyon-opcode-sub malyon-opcode-mul
malyon-opcode-div malyon-opcode-mod
malyon-opcode-calls malyon-opcode-calln
malyon-opcode-set-color malyon-opcode-throw
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop malyon-opcode-jz
malyon-opcode-get-sibling malyon-opcode-get-child
malyon-opcode-get-parent malyon-opcode-get-prop-len
malyon-opcode-inc malyon-opcode-dec
malyon-opcode-print-addr malyon-opcode-calls
malyon-opcode-remove-obj malyon-opcode-print-obj
malyon-opcode-ret malyon-opcode-jump
malyon-opcode-print-paddr malyon-opcode-load
malyon-opcode-calln malyon-opcode-jz
malyon-opcode-get-sibling malyon-opcode-get-child
malyon-opcode-get-parent malyon-opcode-get-prop-len
malyon-opcode-inc malyon-opcode-dec
malyon-opcode-print-addr malyon-opcode-calls
malyon-opcode-remove-obj malyon-opcode-print-obj
malyon-opcode-ret malyon-opcode-jump
malyon-opcode-print-paddr malyon-opcode-load
malyon-opcode-calln malyon-opcode-jz
malyon-opcode-get-sibling malyon-opcode-get-child
malyon-opcode-get-parent malyon-opcode-get-prop-len
malyon-opcode-inc malyon-opcode-dec
malyon-opcode-print-addr malyon-opcode-calls
malyon-opcode-remove-obj malyon-opcode-print-obj
malyon-opcode-ret malyon-opcode-jump
malyon-opcode-print-paddr malyon-opcode-load
malyon-opcode-calln malyon-opcode-rtrue
malyon-opcode-rfalse malyon-opcode-print
malyon-opcode-print-ret malyon-opcode-nop
malyon-opcode-illegal malyon-opcode-illegal
malyon-opcode-restart malyon-opcode-ret-popped
malyon-opcode-catch malyon-opcode-quit
malyon-opcode-new-line malyon-opcode-illegal
malyon-opcode-verify malyon-opcode-illegal
malyon-opcode-piracy malyon-opcode-nop
malyon-opcode-je malyon-opcode-jl
malyon-opcode-jg malyon-opcode-dec-chk
malyon-opcode-inc-chk malyon-opcode-jin
malyon-opcode-test malyon-opcode-or
malyon-opcode-and malyon-opcode-test-attr
malyon-opcode-set-attr malyon-opcode-clear-attr
malyon-opcode-store malyon-opcode-insert-obj
malyon-opcode-loadw malyon-opcode-loadb
malyon-opcode-get-prop malyon-opcode-get-prop-addr
malyon-opcode-get-next-prop malyon-opcode-add
malyon-opcode-sub malyon-opcode-mul
malyon-opcode-div malyon-opcode-mod
malyon-opcode-calls malyon-opcode-calln
malyon-opcode-set-color malyon-opcode-throw
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop malyon-opcode-calls
malyon-opcode-storew malyon-opcode-storeb
malyon-opcode-put-prop malyon-opcode-aread
malyon-opcode-print-char malyon-opcode-print-num
malyon-opcode-random malyon-opcode-push
malyon-opcode-pull malyon-opcode-split-window
malyon-opcode-set-window malyon-opcode-calls
malyon-opcode-erase-window malyon-opcode-erase-line
malyon-opcode-set-cursor malyon-opcode-get-cursor
malyon-opcode-set-text-style malyon-opcode-buffer-mode
malyon-opcode-output-stream malyon-opcode-input-stream
malyon-opcode-nop malyon-opcode-read-char
malyon-opcode-scan-table malyon-opcode-not
malyon-opcode-calln malyon-opcode-calln
malyon-opcode-tokenise malyon-opcode-encode-text
malyon-opcode-copy-table malyon-opcode-print-table
malyon-opcode-check-arg-count malyon-opcode-save
malyon-opcode-restore malyon-opcode-log-shift
malyon-opcode-art-shift malyon-opcode-set-font
malyon-opcode-illegal malyon-opcode-illegal
malyon-opcode-illegal malyon-opcode-illegal
malyon-opcode-save-undo malyon-opcode-restore-undo
malyon-opcode-print-unicode malyon-opcode-check-unicode
malyon-opcode-nop malyon-opcode-nop
malyon-opcode-nop]
"A vector of all known legal z code opcodes.")
;; initialization
(defun malyon-load-story-file (file-name)
"Load a z code story file into an internal vector."
(save-excursion
(set-buffer (create-file-buffer file-name))
(malyon-disable-multibyte)
(malyon-erase-buffer)
(let ((coding-system-for-read 'binary))
(insert-file-contents file-name))
(setq malyon-story-file-name file-name)
(setq malyon-story-file (buffer-substring-no-properties (point-min)
(point-max)))
(setq malyon-story-file (malyon-string-to-vector malyon-story-file))
(if (not (eq ?\^A 1))
(let ((i 0))
(while (< i (length malyon-story-file))
(aset malyon-story-file
i
(malyon-char-to-int (aref malyon-story-file i)))
(setq i (+ 1 i)))))
(kill-buffer nil)))
(defun malyon-initialize ()
"Initialize the z code interpreter."
; (malyon-trace-file)
(setq malyon-game-state-quetzal t)
(malyon-initialize-faces)
(malyon-initialize-status)
(malyon-initialize-transcript)
(malyon-initialize-windows)
(malyon-initialize-story-header)
(malyon-initialize-registers)
(malyon-initialize-opcodes)
(malyon-history-clear)
(setq malyon-game-state-restart (malyon-current-game-state))
(malyon-print-header))
(defun malyon-initialize-status ()
"Initialize the status buffer."
(setq malyon-status-buffer (get-buffer-create "Malyon Status"))
(switch-to-buffer malyon-status-buffer)
(malyon-erase-buffer)
(kill-all-local-variables)
(setq malyon-status-buffer-point (point))
(setq malyon-status-buffer-lines 0)
(setq malyon-status-buffer-delayed-split nil)
(use-local-map malyon-keymap-read)
(set-syntax-table malyon-syntax-table)
(setq mode-name "Malyon")
(setq major-mode 'malyon-mode)
(run-hooks 'malyon-mode-hook))
(defun malyon-initialize-transcript ()
"Initialize the transcript buffer."
(setq malyon-transcript-buffer (get-buffer-create "Malyon Transcript"))
(switch-to-buffer malyon-transcript-buffer)
(malyon-erase-buffer)
(kill-all-local-variables)
(setq malyon-last-cursor-position-after-input
(malyon-point-max malyon-transcript-buffer))
(use-local-map malyon-keymap-read)
(set-syntax-table malyon-syntax-table)
(setq fill-column malyon-max-column)
(auto-fill-mode 1)
(setq mode-name "Malyon")
(setq major-mode 'malyon-mode)
(run-hooks 'malyon-mode-hook))
(defun malyon-initialize-windows ()
"Initialize the window configuration for the z machine."
(setq window-min-height 3)
(setq malyon-transcript-buffer-buffered t)
(malyon-set-window-configuration 0)
(malyon-opcode-set-window 0))
(defun malyon-initialize-story-header ()
"Initializes the header section of the story file."
(malyon-store-byte 1
(if (>= malyon-story-version 5)
28
(logior 48 (malyon-read-byte 1))))
(malyon-store-byte 16 (logand 440 (malyon-read-byte 16)))
(malyon-store-byte 30 1)
(malyon-store-byte 31 65)
(malyon-store-byte 32 255)
(malyon-store-byte 33 (- malyon-max-column 1))
(malyon-store-word 34 (- malyon-max-column 1))
(malyon-store-word 36 255)
(malyon-store-word 38 1)
(malyon-store-word 39 1)
(malyon-store-byte 44 0)
(malyon-store-byte 45 0)
(malyon-store-byte 50 1)
(malyon-store-byte 51 0))
(defun malyon-initialize-registers ()
"Initialize the interpreter's internal registers."
(setq malyon-stack (make-vector 1024 0))
(setq malyon-stack-pointer -1)
(malyon-push-initial-frame)
(setq malyon-frame-pointer malyon-stack-pointer)
(setq malyon-instruction-pointer (malyon-read-word 6))
(setq malyon-global-variables (malyon-read-word 12))
(setq malyon-object-table (malyon-read-word 10))
(cond ((< malyon-story-version 5)
(setq malyon-object-table-entry-size 9)
(setq malyon-object-properties 31)
(setq malyon-object-property-offset 7))
(t
(setq malyon-object-table-entry-size 14)
(setq malyon-object-properties 63)
(setq malyon-object-property-offset 12)))
(setq malyon-abbreviations (malyon-read-word 24))
(if (< malyon-story-version 5)
(setq malyon-score-game (zerop (logand 2 (malyon-read-byte 1)))))
(setq malyon-packed-multiplier
(malyon-cadr (assq malyon-story-version '((3 2) (5 4) (8 8)))))
(if (or (< malyon-story-version 5) (zerop (malyon-read-word 52)))
(setq malyon-alphabet (concat "abcdefghijklmnopqrstuvwxyz"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
" \n0123456789.,!?_#'\"/\\-:()"))
(setq malyon-alphabet (make-string 78 ? ))
(let ((i 0))
(while (< i 78)
(aset malyon-alphabet i
(malyon-read-byte (+ i (malyon-read-word 52))))
(setq i (+ 1 i)))))
(malyon-initialize-unicode-table)
(setq malyon-dictionary (malyon-read-word 8))
(setq malyon-dictionary-entry-length
(malyon-read-byte
(+ 1 malyon-dictionary (malyon-read-byte malyon-dictionary))))
(setq malyon-dictionary-num-entries
(malyon-read-word
(+ 2 malyon-dictionary (malyon-read-byte malyon-dictionary))))
(setq malyon-dictionary-entries
(+ 4 malyon-dictionary (malyon-read-byte malyon-dictionary)))
(setq malyon-dictionary-word-length (if (< malyon-story-version 5) 3 5))
(setq malyon-current-face 'malyon-face-plain)
(setq malyon-print-separator nil)
(malyon-initialize-output-streams))
(defun malyon-initialize-opcodes ()
"Initialize the opcode table used by the story file."
(cond ((< malyon-story-version 5)
(aset malyon-opcodes 143 'malyon-opcode-not)
(aset malyon-opcodes 181 'malyon-opcode-save)
(aset malyon-opcodes 182 'malyon-opcode-restore)
(aset malyon-opcodes 185 'malyon-opcode-pop)
(aset malyon-opcodes 188 'malyon-opcode-show-status))
(t
(aset malyon-opcodes 143 'malyon-opcode-calln)
(aset malyon-opcodes 181 'malyon-opcode-illegal)
(aset malyon-opcodes 182 'malyon-opcode-illegal)
(aset malyon-opcodes 185 'malyon-opcode-catch)
(aset malyon-opcodes 188 'malyon-opcode-illegal))))
(defun malyon-print-header ()
"Print malyon mode header information."
(malyon-opcode-set-text-style 2)
(malyon-print "Malyon V 1.0.3")
(malyon-opcode-set-text-style 0)
(malyon-newline)
(malyon-print "A z-code interpreter for version 3, 5, and 8 games.")
(malyon-newline)
(malyon-print "(c) 1999-2011 by Peter Ilberg <
[email protected]>")
(malyon-newline)
(malyon-newline))
;; cleanup
(defun malyon-cleanup ()
"Clean up the z code interpreter."
(condition-case nil
(progn
(setq malyon-story-file nil)
(setq malyon-window-configuration nil)
(setq malyon-game-state-restart nil)
(setq malyon-game-state-undo nil)
(if (get-buffer "Malyon Status")
(kill-buffer (get-buffer "Malyon Status")))
(if (get-buffer "Malyon Transcript")
(progn
(switch-to-buffer (get-buffer "Malyon Transcript"))
(malyon-redisplay-frame (selected-frame) t)
(delete-other-windows (get-buffer-window (current-buffer)))
(widen)
(text-mode)))
(setq malyon-status-buffer nil)
(setq malyon-transcript-buffer nil))
(error
(malyon-fatal-error "cleanup failed."))))
;; error handling
(defun malyon-fatal-error (message)
"Print error message and abort."
(setq message (concat "Malyon fatal error: " message))
(unwind-protect
(save-excursion
(set-buffer malyon-transcript-buffer)
(goto-char (point-max))
(newline)
(newline)
(put-text-property 0
(length message)
'face
'malyon-face-error
message)
(insert message)
(newline))
(malyon-cleanup)
(malyon-redisplay-frame (selected-frame) t)
(error message)))
;; conversion of zscii to ascii
(defvar malyon-unicode-table nil
"An array mapping zscii characters to latin-1 ones.")
(defvar malyon-default-unicode-table nil
"The default array mapping zscii characters to latin-1 ones.")
(if malyon-default-unicode-table
'()
(setq malyon-default-unicode-table
[32
0 0 0 0 0 0 0 ; 1 - 7
8 0 0 0 0 10 0 0 ; 8 - 15
0 0 0 0 0 0 0 0 ; 16 - 23
0 0 0 39 0 0 0 0 ; 24 - 31
32 33 34 35 36 37 38 39 ; 32 - 39
40 41 42 43 44 45 46 47 ; 40 - 47
48 49 50 51 52 53 54 55 ; 48 - 55
56 57 58 59 60 61 62 63 ; 56 - 63
64 65 66 67 68 69 70 71 ; 64 - 71
72 73 74 75 76 77 78 79 ; 72 - 79
80 81 82 83 84 85 86 87 ; 80 - 87
88 89 90 91 92 93 94 95 ; 88 - 95
96 97 98 99 100 101 102 103 ; 96 - 103
104 105 106 107 108 109 110 111 ; 104 - 111
112 113 114 115 116 117 118 119 ; 112 - 119
120 121 122 123 124 125 126 0 ; 120 - 127
0 0 0 0 0 0 0 0 ; 128 - 135
0 0 0 0 0 0 0 0 ; 136 - 143
0 48 49 50 51 52 53 54 ; 144 - 151
55 56 57 228 246 252 196 214 ; 152 - 159
220 223 187 171 235 239 255 203 ; 160 - 167
207 225 233 237 243 250 253 193 ; 168 - 175
201 205 211 218 221 224 232 236 ; 176 - 183
242 249 192 200 204 210 217 226 ; 184 - 191
234 238 244 251 194 202 206 212 ; 192 - 199
219 229 197 248 216 227 241 245 ; 200 - 207
195 209 213 230 198 231 199 254 ; 208 - 215
240 222 208 163 63 63 161 191 ; 216 - 223
0 0 0 0 0 0 0 0 ; 224 - 231
0 0 0 0 0 0 0 0 ; 232 - 239
0 0 0 0 0 0 0 0 ; 240 - 247
0 0 0 0 0 0 0 0 ; 248 - 255
]))
(defun malyon-initialize-unicode-table ()
"Initializes the zscii-to-unicode conversion table."
(setq malyon-unicode-table
(copy-sequence malyon-default-unicode-table))
(let* ((ext (malyon-read-word 54))
(len (if (zerop ext) 0 (malyon-read-word ext)))
(table (if (< len 3) 0 (malyon-read-word (+ ext 6)))))
(if (or (< malyon-story-version 5) (zerop table))
'()
(let ((i 0))
(while (< i 96)
(aset malyon-unicode-table (+ 155 i) (malyon-char-to-int ??))
(setq i (+ 1 i))))
(setq len (malyon-read-byte table))
(let ((i 0))
(while (< i len)
(aset malyon-unicode-table (+ 155 i)
(malyon-read-word (+ table 1 i)))
(setq i (+ 1 i)))))))
(defsubst malyon-zscii-to-unicode (char)
"Converts a zscii character to unicode."
(if (or (< char 0) (> char 255))
??
(let ((uni (aref malyon-unicode-table char)))
(if (zerop uni)
??
(malyon-unibyte-char-to-multibyte (malyon-int-to-char uni))))))
(defsubst malyon-unicode-to-zscii (char)
"Converts a unicode character to zscii."
(setq char (malyon-multibyte-char-to-unibyte char))
(setq char (if (malyon-characterp char) (malyon-char-to-int char) char))
(if (= 13 char)
?\r
(let ((i 1) (found 0))
(while (and (< i 255) (zerop found))
(if (= char (aref malyon-unicode-table i))
(setq found i))
(setq i (+ i 1)))
(malyon-int-to-char found))))
;; output streams
(defvar malyon-output-streams nil
"Valid output streams for the interpreter.")
(defvar malyon-output-streams-tables nil
"A list of active tables for stream 3.")
(defun malyon-initialize-output-streams ()
"Initializes the output streams."
(setq malyon-output-streams '())
(setq malyon-output-streams-tables '())
(malyon-add-output-stream 1 0))
(defun malyon-output-stream-function (stream)
"Returns the output function representing the given stream."
(cond ((= 1 stream) (if (zerop malyon-current-window)
'malyon-putchar-transcript
'malyon-putchar-status))
((= 2 stream) 'malyon-putchar-printer)))
(defun malyon-add-output-stream (stream table)
"Add a new output stream."
(if (= stream 3)
(progn
(setq malyon-output-streams-tables
(cons table malyon-output-streams-tables))
(malyon-store-word table 0))
(let ((function (malyon-output-stream-function stream)))
(setq malyon-output-streams
(if (member function malyon-output-streams)
malyon-output-streams
(cons function malyon-output-streams))))))
(defun malyon-remove-output-stream (stream)
"Remove an output stream."
(if (= stream 3)
(setq malyon-output-streams-tables (cdr malyon-output-streams-tables))
(setq malyon-output-streams
(malyon-remove (malyon-output-stream-function stream)
malyon-output-streams))))
(defun malyon-update-output-streams ()
"Update output streams when the output window has changed."
(let ((one (or (member 'malyon-putchar-transcript malyon-output-streams)
(member 'malyon-putchar-status malyon-output-streams))))
(setq malyon-output-streams
(malyon-remove 'malyon-putchar-transcript
(malyon-remove 'malyon-putchar-status
malyon-output-streams)))
(if one
(malyon-add-output-stream 1 0))))
(defsubst malyon-output-character (char)
"Output a single character on all active streams."
(setq char (malyon-zscii-to-unicode char))
(if malyon-output-streams-tables
(malyon-putchar-table char (car malyon-output-streams-tables))
(malyon-mapc (lambda (s) (funcall s char)) malyon-output-streams)))
;; printing text
(defsubst malyon-abbrev (abbrev x)
"Print an abbreviation."
(malyon-print-ztext
(* 2 (malyon-read-word (+ malyon-abbreviations
(* 2 (+ x (* 32 (1- abbrev)))))))))
(defun malyon-newline ()
"Print a newline."
(if (eq malyon-status-buffer (current-buffer))
(goto-char malyon-status-buffer-point)
(goto-char (point-max)))
(malyon-output-character ?\r)
(if (eq malyon-status-buffer (current-buffer))
(setq malyon-status-buffer-point (point))
(goto-char malyon-last-cursor-position-after-input))
(malyon-redisplay-frame (selected-frame) nil))
(defun malyon-print (object)
"Print text."
(let ((text (if (malyon-characterp object) (char-to-string object) object))
(start))
(if (eq malyon-transcript-buffer (current-buffer))
(goto-char (point-max))
(goto-char malyon-status-buffer-point))
(setq start (point))
(malyon-print-characters (malyon-string-to-list text))
(put-text-property start (point) 'face malyon-current-face)
(if (eq malyon-status-buffer (current-buffer))
(setq malyon-status-buffer-point (point))
(goto-char malyon-last-cursor-position-after-input))))
(defun malyon-print-characters (text)
"Print a list of characters."
(malyon-mapc 'malyon-output-character text))
(defsubst malyon-print-state-new (char shift abbr zscii zcode)
"Generate a new print state."
(list char shift abbr zscii zcode))
(defsubst malyon-print-state-initial ()
"Returns an initial state for the ztext decoder."
(malyon-print-state-new nil -6 0 0 0))
(defsubst malyon-print-state-next (x ignore shift abbr zscii z)
"Print state transition function."
(cond ((= zscii 2)
(malyon-print-state-new (+ z x) -6 0 0 0))
((= zscii 1)
(malyon-print-state-new nil -6 0 2 (* 32 x)))
((> abbr 0)
(malyon-abbrev abbr x)
(malyon-print-state-initial))
((= x 0)
(malyon-print-state-new ? -6 0 0 0))
((< x 4)
(malyon-print-state-new nil -6 x 0 0))
((= x 4)
(malyon-print-state-new nil 20 0 0 0))
((= x 5)
(malyon-print-state-new nil 46 0 0 0))
((and (= shift 46) (= x 6))
(malyon-print-state-new nil -6 0 1 0))
((and (= shift 46) (= x 7))
(malyon-print-state-new ?\r -6 0 0 0))
(t
(malyon-print-state-new
(aref malyon-alphabet (+ shift x)) -6 0 0 0))))
(defun malyon-print-text (address)
"Print text at address and return the address of the following byte."
(let ((start))
(if (eq malyon-transcript-buffer (current-buffer))
(goto-char (point-max))
(goto-char malyon-status-buffer-point))
(setq start (point))
(setq address (malyon-print-ztext address))
(put-text-property start (point) 'face malyon-current-face)
(if (eq malyon-status-buffer (current-buffer))
(setq malyon-status-buffer-point (point))
(goto-char malyon-last-cursor-position-after-input))
(malyon-redisplay-frame (selected-frame) nil)
address))
(defun malyon-print-ztext (address)
"Print the ztext stored at the given address."
(let ((high 0) (low) (a) (b) (c) (state (malyon-print-state-initial)))
(while (zerop (logand 128 high))
(setq high (malyon-read-byte address))
(setq low (malyon-read-byte (+ 1 address)))
(setq a (logand 31 (lsh high -2)))
(setq b (logand 31 (logior (lsh high 3) (lsh low -5))))
(setq c (logand 31 low))
(setq state (apply 'malyon-print-state-next a state))
(if (car state) (malyon-output-character (car state)))
(setq state (apply 'malyon-print-state-next b state))
(if (car state) (malyon-output-character (car state)))
(setq state (apply 'malyon-print-state-next c state))
(if (car state) (malyon-output-character (car state)))
(setq address (+ 2 address)))
address))
(defun malyon-putchar-transcript (char)
"Print a single character in the transcript window."
(if (char-equal char ?\n)
(newline 1)
(insert char)
(setq malyon-print-separator (null (member char malyon-whitespace))))
(if (and malyon-transcript-buffer-buffered
(> (current-column) (current-fill-column)))
(progn
(end-of-line)
(forward-word -1)
(if (< 0 (current-column))
(newline 1))
(end-of-line))))
(defun malyon-putchar-status (char)
"Print a single character in the status window."
(if malyon-status-buffer-delayed-split
(progn
(malyon-split-buffer-windows malyon-status-buffer-delayed-split)
(other-window 1)))
(if (char-equal char ?\n)
(progn
(beginning-of-line)
(forward-line 1)
(if (= (point) (point-max))
(forward-line -1)))
(if (> (current-column) (current-fill-column))
'()
(insert char)
(delete-char 1))))
(defun malyon-putchar-table (char table)
"Print a single character into a table."
(setq char (malyon-unicode-to-zscii char))
(malyon-store-byte (+ 2 table (malyon-read-word table)) char)
(malyon-store-word table (+ 1 (malyon-read-word table))))
(defun malyon-putchar-printer (char)
"Print a single character onto a printer."); not yet implemented
;; more
(defvar malyon-more-continue-keymap nil
"The keymap with which to continue after More has finished.")
(defun malyon-more (keymap)
"Enter More mode."
(if (eq malyon-status-buffer (current-buffer))
(use-local-map keymap)
(if (< malyon-story-version 5) (malyon-opcode-show-status))
(if (< (count-lines malyon-last-cursor-position-after-input (point-max))
(malyon-window-displayed-height))
(progn
(malyon-adjust-transcript)
(use-local-map keymap))
(goto-char malyon-last-cursor-position-after-input)
(beginning-of-line)
(recenter 1)
(setq malyon-more-continue-keymap keymap)
(use-local-map malyon-keymap-more)
(message "[More]"))))
(defun malyon-more-status-buffer ()
"Enter More mode for the status buffer."
(setq malyon-more-continue-keymap (current-local-map))
(use-local-map malyon-keymap-more-status)
(message "[More]")
(throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
;; input history
(defvar malyon-history nil
"The input history.")
(defun malyon-history-previous ()
"Move one entry up in the input history."
(let ((prev (aref malyon-history 0))
(curr (aref malyon-history 1))
(next (aref malyon-history 2)))
(if (null prev)
curr
(aset malyon-history 2 (if curr (cons curr next) next))
(aset malyon-history 0 (cdr prev))
(aset malyon-history 1 (car prev)))))
(defun malyon-history-next ()
"Move one entry down in the input history."
(let ((prev (aref malyon-history 0))
(curr (aref malyon-history 1))
(next (aref malyon-history 2)))
(if (null next)
curr
(aset malyon-history 0 (if curr (cons curr prev) prev))
(aset malyon-history 2 (cdr next))
(aset malyon-history 1 (car next)))))
(defun malyon-history-clear ()
"Clear the input history."
(setq malyon-history (vector '() nil '())))
(defun malyon-history-insert (entry)
"Insert an entry into the input history."
(let* ((prev (aref malyon-history 0))
(curr (aref malyon-history 1))
(next (aref malyon-history 2))
(l (malyon-remove entry
(append (nreverse prev)
(if curr (cons curr next) next))))
(cut (- (length l) 19)))
(while (> cut 0)
(setq l (cdr l)
cut (- cut 1)))
(aset malyon-history 0
(malyon-remove nil (malyon-remove "" (cons entry (nreverse l)))))
(aset malyon-history 1 nil)
(aset malyon-history 2 '())))
;; dictionary lookup
(defun malyon-dictionary-word (chars)
"Convert a list of characters into a dictionary word."
(list (car (car chars))
(length chars)
(malyon-encode-dictionary-word (append (malyon-mapcan 'cdr chars)
'(5 5 5 5 5 5 5 5)))))
(defsubst malyon-join-characters (stop list)
"Joins three ztext characters into two bytes."
(let ((a (car list))
(b (malyon-cadr list))
(c (malyon-caddr list))
(x (if (zerop stop) 0 128)))
(list (logior x (logand 255 (logior (lsh a 2) (lsh b -3))))
(logand 255 (logior (lsh b 5) c)))))
(defun malyon-encode-dictionary-word (l)
"Converts a list of ztext characters into a dictionary word."
(let* ((first l)
(second (malyon-cdddr first))
(third (malyon-cdddr second)))
(apply 'vector
(if (< malyon-story-version 5)
(append (malyon-join-characters 0 first)
(malyon-join-characters 1 second))
(append (malyon-join-characters 0 first)
(malyon-join-characters 0 second)
(malyon-join-characters 1 third))))))
(defun malyon-lookup (dict code)
"Look for the given code in the dictionary and return its address."
(cond ((not code) 0)
((not dict) (malyon-binary-search code))
((= dict malyon-dictionary) (malyon-binary-search code))
(t (malyon-linear-search dict code))))
(defsubst malyon-compare-words (word address)
"Compares the given word to the word stored at address."
(let* ((i 0)
(j address)
(x (aref word i))
(y (malyon-read-byte j)))
(while (not (or (/= x y) (= i malyon-dictionary-word-length)))
(setq i (+ 1 i)
j (+ 1 j)
x (aref word i)
y (malyon-read-byte j)))
(- x y)))
;; search functions
(defun malyon-binary-search (code)
"Binary search through the main dictionary."
(let* ((lower 0)
(upper (- malyon-dictionary-num-entries 1))
(median (/ (+ lower upper) 2))
(entry (+ malyon-dictionary-entries
(* malyon-dictionary-entry-length median)))
(looking (malyon-compare-words code entry)))
(while (not (or (> lower upper) (zerop looking)))
(setq lower (if (< 0 looking) (+ median 1) lower)
upper (if (> 0 looking) (- median 1) upper)
median (/ (+ lower upper) 2)
entry (+ malyon-dictionary-entries
(* malyon-dictionary-entry-length median))
looking (malyon-compare-words code entry)))
(if (zerop looking) entry 0)))
(defun malyon-linear-search (dictionary code)
"Linear search through the given dictionary."
(let* ((length (malyon-read-byte (+ dictionary 1
(malyon-read-byte dictionary))))
(number (malyon-read-word (+ dictionary 2
(malyon-read-byte dictionary))))
(entries (+ dictionary 4 (malyon-read-byte dictionary)))
(i 0)
(entry (+ entries (* length i)))
(looking (malyon-compare-words code entry)))
(while (not (or (>= i number) (zerop looking)))
(setq i (+ 1 i)
entry (+ entries (* length i))
looking (malyon-compare-words code entry)))
(if (zerop looking) entry 0)))
;; encoding text and lexical analysis
(defun malyon-split-list (sep list &optional x)
"Split a list into sublists as indicated by the separators."
(cond ((null list)
(list (nreverse x)))
((eq sep (car list))
(cons (nreverse x) (malyon-split-list sep (cdr list) '())))
(t
(malyon-split-list sep (cdr list) (cons (car list) x)))))
(defun malyon-characters-to-words (list)
"Turn the list of characters into a list of words."
(mapcar 'malyon-dictionary-word
(delete '() (malyon-split-list 'malyon-word-separator list))))
(defsubst malyon-char-in-string (c s)
"Returns the index of c in s if found, or length of s."
(let ((i 0))
(while (not (or (= i (length s)) (= c (aref s i))))
(setq i (+ 1 i)))
i))
(defsubst malyon-encode-into-ztext (c)
"Convert a character into ztext."
(let* ((index (malyon-char-in-string c malyon-alphabet))
(shift (floor index 26))
(char (+ 6 (mod index 26))))
(cond ((> shift 2) (list 5 6 (logand 31 (lsh c -5)) (logand 31 c)))
((= shift 2) (list 5 char))
((= shift 1) (list 4 char))
(t (list char)))))
(defun malyon-encode-single-character (terminating-characters char)
"Encode a character into ztext."
(let ((pos (car char))
(c (cdr char)))
(cond ((member c malyon-whitespace)
(list 'malyon-word-separator))
((member c terminating-characters)
(list 'malyon-word-separator
(cons pos (malyon-encode-into-ztext c))
'malyon-word-separator))
(t (list (cons pos (malyon-encode-into-ztext c)))))))
(defun malyon-encode-character-list (dict list)
"Encode the list of characters into ztext."
(let ((l '())
(i 0))
(while (< i (malyon-read-byte dict))
(setq l (cons (malyon-read-byte (+ dict 1 i)) l)
i (+ 1 i)))
(malyon-mapcan (lambda (x) (malyon-encode-single-character l x)) list)))
(defun malyon-text-length (address)
"Return the length of the input text."
(if (>= malyon-story-version 5)
(malyon-read-byte (+ 1 address))
(let ((i 0))
(while (not (zerop (malyon-read-byte (+ i 1 address))))
(setq i (+ i 1)))
i)))
(defun malyon-text-to-character-list (address)
"Convert the input text into a list of characters."
(let ((i (malyon-text-length address))
(text '()))
(while (< 0 i)
(setq text (cons
(cons (if (< malyon-story-version 5) i (+ 1 i))
(malyon-read-byte
(+ i address (if (< malyon-story-version 5) 0 1))))
text)
i (- i 1)))
text))
(defun malyon-text-to-words (address dictionary)
"Turn ztext into a list of dictionary words."
(malyon-characters-to-words
(malyon-encode-character-list (if dictionary dictionary malyon-dictionary)
(malyon-text-to-character-list address))))
;; window management
(defvar malyon-status-buffer-grew-this-turn nil
"A flag signalling if the status buffer grew this turn.")
(defun malyon-adjust-transcript ()
"Adjust the position of the transcript text."
(save-excursion
(setq malyon-status-buffer-grew-this-turn nil)
(set-buffer malyon-transcript-buffer)
(goto-char (point-max))
(recenter (- (malyon-window-displayed-height) 2))))
(defun malyon-prepare-status-buffer (status)
"Fill the status buffer with empty lines."
(save-excursion
(set-buffer malyon-status-buffer)
(let ((lines (count-lines (point-min) (point-max)))
(new status))
(if (zerop lines)
(newline 1))
(goto-char (point-max))
(setq status (- status lines -1))
(while (> status 0)
(insert (make-string (+ 3 malyon-max-column) ? ))
(newline 1)
(setq status (- status 1)))
(goto-char (point-min))
(forward-line (+ 1 new))
(kill-region (point) (point-max))
(insert (make-string (+ 3 malyon-max-column) ? ))
(newline 1))))
(defun malyon-restore-window-configuration ()
"Restore the saved window configuration."
(let ((buffer (window-buffer (selected-window))))
(if malyon-window-configuration
(set-window-configuration malyon-window-configuration))
(cond ((eq malyon-status-buffer buffer) (other-window 1))
((eq malyon-transcript-buffer buffer) (goto-char (point-max))))))
(defun malyon-set-window-configuration (status)
"Set up the new window configuration."
(cond ((< status malyon-status-buffer-lines)
(setq malyon-status-buffer-delayed-split status)
(if malyon-status-buffer-grew-this-turn
(malyon-more-status-buffer)))
((> status malyon-status-buffer-lines)
(malyon-split-buffer-windows status)
(setq malyon-status-buffer-grew-this-turn t))
((not malyon-window-configuration)
(malyon-split-buffer-windows status))))
(defun malyon-split-buffer-windows (status)
"Split the buffer windows.
The status buffer gets 'status' lines while the transcript buffer
gets the remaining lines."
(delete-other-windows (get-buffer-window (current-buffer)))
(setq malyon-status-buffer-lines status)
(setq malyon-status-buffer-delayed-split nil)
(if (zerop status)
'()
(split-window (get-buffer-window (current-buffer)) (+ status 3))
(switch-to-buffer malyon-status-buffer)
(malyon-prepare-status-buffer status)
(malyon-opcode-set-cursor 1 1)
(other-window 1))
(switch-to-buffer malyon-transcript-buffer)
(setq malyon-window-configuration (current-window-configuration)))
;; getting and setting the machine state
(defun malyon-current-game-state ()
"Return the current state of the interpreter."
(vector malyon-instruction-pointer
malyon-stack-pointer
malyon-frame-pointer
(copy-sequence malyon-stack)
(copy-sequence malyon-story-file)
malyon-game-state-quetzal))
(defun malyon-set-game-state (state)
"Installs the given state as the new state of the interpreter."
(setq malyon-instruction-pointer (aref state 0))
(setq malyon-stack-pointer (aref state 1))
(setq malyon-frame-pointer (aref state 2))
(setq malyon-stack (copy-sequence (aref state 3)))
(setq malyon-story-file (copy-sequence (aref state 4)))
(setq malyon-game-state-quetzal (aref state 5))
(save-excursion
(malyon-erase-buffer malyon-status-buffer)
(malyon-split-buffer-windows 0)
(setq malyon-last-cursor-position-after-input
(malyon-point-max malyon-transcript-buffer))))
;; file utilities
(defsubst malyon-write-byte-to-file (byte)
"Write a byte to a file."
(insert-char (logand 255 byte) 1))
(defsubst malyon-write-word-to-file (word)
"Write a word to the last opened file."
(insert-char (logand 255 (lsh word -8)) 1)
(insert-char (logand 255 word) 1))
(defsubst malyon-write-dword-to-file (dword)
"Write a dword to the last opened file."
(insert-char (logand 255 (lsh dword -24)) 1)
(insert-char (logand 255 (lsh dword -16)) 1)
(insert-char (logand 255 (lsh dword -8)) 1)
(insert-char (logand 255 dword) 1))
(defsubst malyon-write-chunk-id-to-file (id)
"Write a quetzal chunk id to the last opened file."
(insert id))
(defsubst malyon-read-byte-from-file ()
"Read the next byte from a file."
(if (= (point) (point-max))
0
(forward-char 1)
(malyon-char-to-int (malyon-char-before))))
(defsubst malyon-read-word-from-file ()
"Read the next word from the last opened file."
(logior (lsh (malyon-read-byte-from-file) 8) (malyon-read-byte-from-file)))
(defsubst malyon-read-dword-from-file ()
"Read the next dword from the last opened file."
(logior (lsh (malyon-read-byte-from-file) 24)
(lsh (malyon-read-byte-from-file) 16)
(lsh (malyon-read-byte-from-file) 8)
(malyon-read-byte-from-file)))
(defsubst malyon-read-chunk-id-from-file ()
"Read a quetzal chunk id from the last opened file."
(string (malyon-int-to-char (malyon-read-byte-from-file))
(malyon-int-to-char (malyon-read-byte-from-file))
(malyon-int-to-char (malyon-read-byte-from-file))
(malyon-int-to-char (malyon-read-byte-from-file))))
(defun malyon-get-file-name (address)
"Retrieves the file name stored at address."
(let ((name (make-string (malyon-read-byte address) ? ))
(i 0))
(while (< i (length name))
(aset name i (malyon-read-byte (+ address 1 i)))
(setq i (+ 1 i)))
name))
;; saving data to disk
(defun malyon-save-file (file &optional table length)
"Save the current game state or a memory section to disk."
(interactive "FSave file: ")
(condition-case nil
(save-excursion
(set-buffer (create-file-buffer file))
(malyon-disable-multibyte)
(malyon-erase-buffer)
(cond (table (malyon-save-table table length))
(malyon-game-state-quetzal
(malyon-save-quetzal-state (malyon-current-game-state)))
(t
(malyon-save-game-state (malyon-current-game-state))))
(let ((coding-system-for-write 'binary))
(write-file file))
(kill-buffer nil)
1)
(error 0)))
(defun malyon-save-table (table length)
"Save the given section of memory to the file."
(let ((i 0)
(j table))
(while (< i length)
(malyon-write-byte-to-file (malyon-read-byte j))
(setq i (+ 1 i)
j (+ 1 j)))))
(defun malyon-save-game-state (state)
"Saves the game state to disk."
(let ((ip (aref state 0))
(sp (aref state 1))
(fp (aref state 2))
(stack (aref state 3))
(mem (aref state 4))
(dyn (malyon-read-word 14))
(i 0))
(malyon-write-word-to-file (length malyon-story-file-name))
(while (< i (length malyon-story-file-name))
(malyon-write-byte-to-file (aref malyon-story-file-name i))
(setq i (+ 1 i)))
(malyon-write-dword-to-file ip)
(malyon-write-word-to-file sp)
(malyon-write-word-to-file fp)
(malyon-write-word-to-file dyn)
(setq i 0)
(while (<= i sp)
(malyon-write-dword-to-file (aref stack i))
(setq i (+ 1 i)))
(setq i 0)
(while (< i dyn)
(malyon-write-byte-to-file (aref mem i))
(setq i (+ 1 i)))))
(defun malyon-save-quetzal-state (state)
"Saves the game state to disk in quetzal format."
(goto-char (point-min))
(malyon-save-quetzal-ifhd state)
(malyon-save-quetzal-cmem state)
(malyon-save-quetzal-stks state)
(goto-char (point-min))
(malyon-write-chunk-id-to-file "IFZS")
(goto-char (point-min))
(malyon-write-dword-to-file (- (point-max) (point-min)))
(goto-char (point-min))
(malyon-write-chunk-id-to-file "FORM"))
(defun malyon-save-quetzal-ifhd (state)
"Saves the IFhd chunk of the quetzal format."
(malyon-write-chunk-id-to-file "IFhd")
(malyon-write-dword-to-file 13)
(malyon-write-word-to-file (malyon-read-word 2))
(malyon-write-word-to-file (malyon-read-word 18))
(malyon-write-word-to-file (malyon-read-word 20))
(malyon-write-word-to-file (malyon-read-word 22))
(malyon-write-word-to-file (malyon-read-word 28))
(malyon-write-byte-to-file (lsh (aref state 0) -16))
(malyon-write-byte-to-file (lsh (aref state 0) -8))
(malyon-write-byte-to-file (aref state 0))
(malyon-write-byte-to-file 0))
(defun malyon-save-quetzal-cmem (state)
"Saves the CMem chunk of the quetzal format."
(let ((beginning (point-max))
(original (aref malyon-game-state-restart 4))
(current (aref state 4))
(size (malyon-read-word 14))
(byte 0)
(count 0)
(i 0))
(goto-char (point-max))
(while (< i size)
(setq byte (logxor (aref current i) (aref original i)))
(if (zerop byte)
(setq count (+ 1 count))
(while (> count 0)
(malyon-write-byte-to-file 0)
(setq count (- count 1))
(malyon-write-byte-to-file (min 255 count))
(setq count (- count (min 255 count))))
(malyon-write-byte-to-file byte))
(setq i (+ 1 i)))
(setq size (- (point-max) beginning))
(if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
(goto-char beginning)
(malyon-write-chunk-id-to-file "CMem")
(malyon-write-dword-to-file size)))
(defun malyon-save-quetzal-stks (state)
"Saves the Stks chunk of the quetzal format."
(let ((beginning (point-max))
(size 0))
(goto-char (point-max))
(malyon-save-quetzal-stack-frame (- (aref state 2) 4)
(aref state 1)
(aref state 3))
(setq size (- (point-max) beginning))
(if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
(goto-char beginning)
(malyon-write-chunk-id-to-file "Stks")
(malyon-write-dword-to-file size)))
(defun malyon-save-quetzal-stack-frame (fp sp stack)
"Saves the stack frames for the Stks chunk."
(let* ((frame (malyon-get-stack-frame fp sp stack))
(frame-id (aref frame 0))
(previous-fp (aref frame 1))
(previous-sp (aref frame 2))
(return-addr (aref frame 3))
(result-addr (aref frame 4))
(local-vars (aref frame 5))
(num-args (aref frame 6))
(eval-stack (aref frame 7)))
(if (> frame-id 0)
(malyon-save-quetzal-stack-frame previous-fp previous-sp stack))
(malyon-write-byte-to-file (lsh return-addr -16))
(malyon-write-byte-to-file (lsh return-addr -8))
(malyon-write-byte-to-file return-addr)
(if (zerop frame-id)
(malyon-write-byte-to-file 0)
(malyon-write-byte-to-file (logior (if result-addr 0 16)
(length local-vars))))
(malyon-write-byte-to-file (if result-addr result-addr 0))
(malyon-write-byte-to-file (- (lsh 1 num-args) 1))
(malyon-write-word-to-file (length eval-stack))
(while (not (null local-vars))
(malyon-write-word-to-file (car local-vars))
(setq local-vars (cdr local-vars)))
(while (not (null eval-stack))
(malyon-write-word-to-file (car eval-stack))
(setq eval-stack (cdr eval-stack)))))
;; restoring data from disk
(defvar malyon-restore-data-error nil
"An error message if restoring data from a file failed.")
(defvar malyon-restore-quetzal-stack nil
"A temporary stack for restoring quetzal game states.")
(defvar malyon-restore-quetzal-stack-pointer nil
"A temporary stack pointer for restoring quetzal game states.")
(defvar malyon-restore-quetzal-frame-pointer nil
"A temporary frame-pointer for restoring quetzal game states.")
(defun malyon-restore-file (file &optional table length)
"Restore a game state or a memory section from disk."
(interactive "fLoad file: ")
(if (not (and (file-exists-p file) (file-readable-p file)))
0
(condition-case nil
(save-excursion
(setq malyon-restore-data-error nil)
(set-buffer (create-file-buffer file))
(malyon-disable-multibyte)
(malyon-erase-buffer)
(let ((coding-system-for-read 'binary))
(insert-file-contents file))
(goto-char (point-min))
(if table
(malyon-restore-table table length)
(let* ((first (malyon-read-chunk-id-from-file))
(second (malyon-read-dword-from-file))
(third (malyon-read-chunk-id-from-file)))
(if (and (string= "FORM" first) (string= "IFZS" third))
(malyon-restore-quetzal-state (+ 8 second))
(goto-char (point-min))
(malyon-restore-game-state))))
(kill-buffer nil)
(if (null malyon-restore-data-error)
2
(message malyon-restore-data-error)
0))
(error 0))))
(defun malyon-restore-table (table length)
"Restore the given section of memory from a file."
(let ((i 0)
(j table))
(while (< i length)
(malyon-store-byte j (malyon-read-byte-from-file))
(setq i (+ 1 i)
j (+ 1 j)))))
(defun malyon-restore-game-state ()
"Restore a saved game state from disk."
(let ((len 0)
(name 0)
(story 0)
(ip 0)
(sp 0)
(fp 0)
(dyn 0)
(stack (copy-sequence malyon-stack))
(mem (copy-sequence malyon-story-file))
(i 0))
(setq len (malyon-read-word-from-file))
(setq name (make-string len ? ))
(while (< i len)
(aset name i (malyon-read-byte-from-file))
(setq i (+ 1 i)))
(setq ip (malyon-read-dword-from-file))
(setq sp (malyon-read-word-from-file))
(setq fp (malyon-read-word-from-file))
(setq dyn (malyon-read-word-from-file))
(setq i 0)
(while (<= i sp)
(aset stack i (malyon-read-dword-from-file))
(setq i (+ 1 i)))
(setq i 0)
(while (< i dyn)
(aset mem i (malyon-read-byte-from-file))
(setq i (+ 1 i)))
(setq name (file-name-nondirectory name))
(setq story (file-name-nondirectory malyon-story-file-name))
(if (or (string-match name story) (string-match story name))
(malyon-set-game-state (vector ip sp fp stack mem nil))
(setq malyon-restore-data-error "Invalid save file."))))
(defun malyon-restore-quetzal-state (size)
"Restore a saved quetzal game state from disk."
(let ((chunk-id nil)
(chunk-len 0)
(ip 0)
(memory nil)
(stack nil)
(beginning 0))
(while (< (point) size)
(setq chunk-id (malyon-read-chunk-id-from-file))
(setq chunk-len (malyon-read-dword-from-file))
(setq beginning (point))
(cond ((string= chunk-id "IFhd")
(setq ip (malyon-restore-quetzal-ifhd chunk-len)))
((string= chunk-id "CMem")
(setq memory (malyon-restore-quetzal-cmem chunk-len)))
((string= chunk-id "UMem")
(setq memory (malyon-restore-quetzal-umem chunk-len)))
((string= chunk-id "Stks")
(setq stack (malyon-restore-quetzal-stks chunk-len))))
(if (zerop (mod chunk-len 2)) '() (setq chunk-len (+ 1 chunk-len)))
(goto-char (+ beginning chunk-len)))
(cond ((and ip memory stack)
(malyon-set-game-state (vector ip
(aref stack 0)
(aref stack 1)
(aref stack 2)
memory
t)))
((null malyon-restore-data-error)
(setq malyon-restore-data-error "invalid quetzal file.")))))
(defun malyon-restore-quetzal-ifhd (size)
"Restore an IFhd chunk from disk. Return the instruction pointer."
(if (and (= (malyon-read-word-from-file) (malyon-read-word 2))
(= (malyon-read-word-from-file) (malyon-read-word 18))
(= (malyon-read-word-from-file) (malyon-read-word 20))
(= (malyon-read-word-from-file) (malyon-read-word 22))
(= (malyon-read-word-from-file) (malyon-read-word 28)))
(logior (lsh (malyon-read-byte-from-file) 16)
(lsh (malyon-read-byte-from-file) 8)
(malyon-read-byte-from-file))
(setq malyon-restore-data-error "quetzal file doesn't belong to game.")
nil))
(defun malyon-restore-quetzal-cmem (size)
"Restore a CMem chunk from disk. Return the entire memory layout."
(let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
(max-size (+ (point) size))
(byte 0)
(i 0))
(while (< (point) max-size)
(setq byte (malyon-read-byte-from-file))
(if (zerop byte)
(setq i (+ 1 i (malyon-read-byte-from-file)))
(aset memory i (logxor byte (aref memory i)))
(setq i (+ 1 i))))
memory))
(defun malyon-restore-quetzal-umem (size)
"Restore a UMem chunk from disk. Return the entire memory layout."
(let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
(i 0))
(while (< i size)
(aset memory i (malyon-read-byte-from-file))
(setq i (+ 1 i)))
memory))
(defun malyon-restore-quetzal-stks (size)
"Restore a Stks chunk from disk. Return a vector containing the
stack pointer, the frame pointer, and the stack itself."
(let ((i 0) (frame-id 0))
(setq malyon-restore-quetzal-stack
(copy-sequence (aref malyon-game-state-restart 3)))
(setq malyon-restore-quetzal-stack-pointer -1)
(setq malyon-restore-quetzal-frame-pointer 2)
(while (< i size)
(let* ((beginning (point))
(return3 (malyon-read-byte-from-file))
(return2 (malyon-read-byte-from-file))
(return1 (malyon-read-byte-from-file))
(return-addr (logior (lsh return3 16) (lsh return2 8) return1))
(result-locals (malyon-read-byte-from-file))
(has-result (zerop (logand 16 result-locals)))
(num-locals (logand 15 result-locals))
(result-addr (malyon-read-byte-from-file))
(arg-flags (+ 1 (malyon-read-byte-from-file)))
(num-args 0)
(eval-size (malyon-read-word-from-file))
(local-vars '())
(eval-stack '()))
(while (> num-locals 0)
(setq local-vars (cons (malyon-read-word-from-file) local-vars))
(setq num-locals (- num-locals 1)))
(while (> eval-size 0)
(setq eval-stack (cons (malyon-read-word-from-file) eval-stack))
(setq eval-size (- eval-size 1)))
(while (> arg-flags 1)
(setq arg-flags (lsh arg-flags -1))
(setq num-args (+ num-args 1)))
(malyon-push-stack-frame frame-id
return-addr
(if (zerop frame-id)
nil
(if has-result result-addr nil))
(reverse local-vars)
num-args
(reverse eval-stack))
(setq frame-id (+ 1 frame-id))
(setq i (+ i (- (point) beginning)))))
(vector malyon-restore-quetzal-stack-pointer
malyon-restore-quetzal-frame-pointer
malyon-restore-quetzal-stack)))
;; object table management
(defsubst malyon-object-address (object)
"Compute the address at which the object is stored."
(+ malyon-object-table
(* 2 malyon-object-properties)
(* malyon-object-table-entry-size (- object 1))))
(defsubst malyon-object-read-parent (address)
"Return the parent."
(if (< malyon-story-version 5)
(malyon-read-byte (+ 4 address))
(malyon-read-word (+ 6 address))))
(defsubst malyon-object-read-sibling (address)
"Return the next sibling."
(if (< malyon-story-version 5)
(malyon-read-byte (+ 5 address))
(malyon-read-word (+ 8 address))))
(defsubst malyon-object-read-child (address)
"Return the first child."
(if (< malyon-story-version 5)
(malyon-read-byte (+ 6 address))
(malyon-read-word (+ 10 address))))
(defsubst malyon-object-store-parent (address value)
"Set the parent."
(if (< malyon-story-version 5)
(malyon-store-byte (+ 4 address) value)
(malyon-store-word (+ 6 address) value)))
(defsubst malyon-object-store-sibling (address value)
"Set the next sibling."
(if (< malyon-story-version 5)
(malyon-store-byte (+ 5 address) value)
(malyon-store-word (+ 8 address) value)))
(defsubst malyon-object-store-child (address value)
"Set the first child."
(if (< malyon-story-version 5)
(malyon-store-byte (+ 6 address) value)
(malyon-store-word (+ 10 address) value)))
(defun malyon-find-property (object property)
"Return the address of the object's property, or 0 if it doesn't exist."
(let ((next (malyon-first-property object))
(number 0))
(setq number (logand (malyon-read-byte next) malyon-object-properties))
(while (> number property)
(setq next (malyon-next-property next))
(setq number (logand (malyon-read-byte next) malyon-object-properties)))
(if (= number property) next 0)))
(defun malyon-first-property (object)
"Get the address of the object's first property."
(let ((header (malyon-read-word (+ malyon-object-property-offset
(malyon-object-address object)))))
(+ header 1 (* 2 (malyon-read-byte header)))))
(defun malyon-next-property (property)
"Get the address of the following property."
(let ((size (malyon-read-byte property))
(addr (+ property 1)))
(+ 1 addr (cond ((< malyon-story-version 5) (lsh size -5))
((zerop (logand 128 size)) (lsh size -6))
(t
(let ((second (logand 63 (malyon-read-byte addr))))
(if (= 0 second) 64 second)))))))
(defun malyon-remove-object (object)
"Remove the object from the children list of its parent."
(let* ((address (malyon-object-address object))
(parent (malyon-object-read-parent address))
(sibling (malyon-object-read-sibling address)))
(malyon-object-store-parent address 0)
(malyon-object-store-sibling address 0)
(if (/= parent 0)
(let ((parent-addr (malyon-object-address parent)))
(let ((children (malyon-object-read-child parent-addr)))
(if (or (= children 0) (= children object))
(malyon-object-store-child parent-addr sibling)
(let ((this (malyon-object-address children)))
(let ((next (malyon-object-read-sibling this)))
(while (/= next object)
(setq this (malyon-object-address next))
(setq next (malyon-object-read-sibling this)))
(malyon-object-store-sibling this sibling)))))))))
;; function calls and code branches
(defun malyon-call-routine (routine arguments &optional result)
"Call a routine with the given arguments and return its result."
(if (= routine 0)
(if result (malyon-store-variable result 0) 0)
(malyon-push-stack (if result 0 1))
(malyon-push-stack (if result result 0))
(malyon-push-stack malyon-instruction-pointer)
(malyon-push-stack
(logior (lsh (- malyon-stack-pointer malyon-frame-pointer) 8)
(length arguments)))
(setq malyon-instruction-pointer (* malyon-packed-multiplier routine))
(let ((args (malyon-read-code-byte)) (value nil))
(if malyon-game-state-quetzal
(let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
(malyon-push-stack (logior (lsh (+ 1 id) 8) args))))
(setq malyon-frame-pointer malyon-stack-pointer)
(while (> args 0)
(setq value (if (< malyon-story-version 5) (malyon-read-code-word) 0))
(malyon-push-stack (if (null arguments) value (car arguments)))
(setq arguments (cdr arguments))
(setq args (- args 1))))))
(defun malyon-jump-if (condition)
"Jump depending on the condition and the following jump data."
(let ((byte (malyon-read-code-byte))
(offset nil)
(iftrue nil))
(setq iftrue (/= 0 (logand byte 128)))
(setq offset (logand byte 63))
(if (= 0 (logand byte 64))
(progn
(setq offset (logior (lsh offset 8) (malyon-read-code-byte)))
(if (>= offset 8192) (setq offset (- offset 16384)))))
(if (or (and iftrue condition) (and (not iftrue) (not condition)))
(progn
(cond ((= offset 0) (malyon-opcode-rfalse))
((= offset 1) (malyon-opcode-rtrue))
(t (setq
malyon-instruction-pointer
(+ malyon-instruction-pointer offset -2))))))))
(defun malyon-return (value)
"Return from a routine."
(setq malyon-stack-pointer malyon-frame-pointer)
(if malyon-game-state-quetzal (malyon-pop-stack))
(setq malyon-frame-pointer
(- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
(setq malyon-instruction-pointer (malyon-pop-stack))
(let ((result (malyon-pop-stack))
(store (malyon-pop-stack)))
(if (zerop store)
(malyon-return-store result value)
(malyon-return-ignore result value))))
(defun malyon-return-ignore (where value)
"Return from a routine ignoring the result.")
(defun malyon-return-store (where value)
"Return from a routine storing the result."
(malyon-store-variable where value))
(defun malyon-push-initial-frame ()
"Push the initial stack frame required in quetzal mode."
(if malyon-game-state-quetzal
(progn
(malyon-push-stack 1)
(malyon-push-stack 0)
(malyon-push-stack 0)
(malyon-push-stack 0)
(malyon-push-stack 0))))
(defun malyon-get-stack-frame (fp sp stack)
"Return a decoded stack frame in quetzal mode.
The result is a vector containing the frame id, the fp of the
previous frame, the sp of the previous frame, the return address,
the result variable if any, a list of local variables, the number
of arguments, and a list of the evaluation stack elements."
(let* ((has-result (zerop (aref stack fp)))
(result-addr (if has-result (aref stack (+ 1 fp)) nil))
(return-addr (aref stack (+ 2 fp)))
(offset (lsh (aref stack (+ 3 fp)) -8))
(num-args (logand 255 (aref stack (+ 3 fp))))
(frame-id (lsh (aref stack (+ 4 fp)) -8))
(num-locals (logand 255 (aref stack (+ 4 fp))))
(start-locals (+ 5 fp))
(start-eval (+ 5 fp num-locals))
(local-vars '())
(eval-stack '()))
(if (not (zerop num-locals))
(setq local-vars
(malyon-vector-to-list stack start-locals start-eval)))
(if (> sp start-eval)
(setq eval-stack
(malyon-vector-to-list stack start-eval (+ 1 sp))))
(vector frame-id
(- fp offset 2)
(- fp 1)
return-addr
result-addr
local-vars
num-args
eval-stack)))
(defsubst malyon-restore-quetzal-push-stack (value)
"Push a value onto the restore quetzal stack."
(setq malyon-restore-quetzal-stack-pointer
(+ malyon-restore-quetzal-stack-pointer 1))
(aset malyon-restore-quetzal-stack
malyon-restore-quetzal-stack-pointer
value))
(defun malyon-push-stack-frame
(frame-id return-addr result local-vars num-args eval-stack)
"Pushes a new stack frame in quetzal mode."
(malyon-restore-quetzal-push-stack (if result 0 1))
(malyon-restore-quetzal-push-stack (if result result 0))
(malyon-restore-quetzal-push-stack return-addr)
(malyon-restore-quetzal-push-stack
(logior (lsh (- malyon-restore-quetzal-stack-pointer
malyon-restore-quetzal-frame-pointer) 8)
num-args))
(malyon-restore-quetzal-push-stack
(logior (lsh frame-id 8) (length local-vars)))
(setq malyon-restore-quetzal-frame-pointer
malyon-restore-quetzal-stack-pointer)
(while (not (null local-vars))
(malyon-restore-quetzal-push-stack (car local-vars))
(setq local-vars (cdr local-vars)))
(while (not (null eval-stack))
(malyon-restore-quetzal-push-stack (car eval-stack))
(setq eval-stack (cdr eval-stack))))
;; other stuff
(defvar malyon-aread-text nil
"Text buffer for user input.")
(defvar malyon-aread-parse nil
"Parse buffer for user input.")
(defvar malyon-aread-beginning-of-line nil
"The beginning of the input line.")
;; execution
(defun malyon-interpreter ()
"Run the z code interpreter on the given story file."
(condition-case nil
(progn
(malyon-restore-window-configuration)
(if malyon-story-file
(catch 'malyon-end-of-interpreter-loop
(setq malyon-last-cursor-position-after-input
(malyon-point-max malyon-transcript-buffer))
(malyon-execute))))
(error
(malyon-fatal-error "unspecified internal runtime error."))))
(defsubst malyon-fetch-variable-operands (specifier)
"Fetch a variable number of operands based on the specifier argument."
(let ((var (logand specifier 49152))
(op '()))
(setq specifier (logand 65535 specifier))
(while (/= 0 specifier)
(cond ((= var 0) (setq op (cons (malyon-read-code-word) op)))
((= var 16384) (setq op (cons (malyon-read-code-byte) op)))
((= var 32768) (setq op (cons (malyon-read-variable
(malyon-read-code-byte)) op)))
(t (setq specifier 0)))
(setq specifier (logand 65535 (lsh specifier 2)))
(setq var (logand specifier 49152)))
(nreverse op)))
(defsubst malyon-fetch-extended (opcode)
"Fetch operands for an extended instruction."
(malyon-fetch-variable-operands
(logior (lsh (malyon-read-code-byte) 8) 255)))
(defsubst malyon-fetch-variable (opcode)
"Fetch operands for a variable instruction."
(malyon-fetch-variable-operands
(if (or (= opcode 236) (= opcode 250))
(malyon-read-code-word)
(logior (lsh (malyon-read-code-byte) 8) 255))))
(defsubst malyon-fetch-short (opcode)
"Fetch operands for a short instruction."
(let ((op (logand opcode 48)))
(cond ((= op 0) (list (malyon-read-code-word)))
((= op 16) (list (malyon-read-code-byte)))
((= op 32) (list (malyon-read-variable (malyon-read-code-byte)))))))
(defsubst malyon-fetch-long (instr)
"Fetch operands for a long instruction."
(let ((byte1 (malyon-read-code-byte))
(byte2 (malyon-read-code-byte)))
(list (if (= (logand instr 64) 0) byte1 (malyon-read-variable byte1))
(if (= (logand instr 32) 0) byte2 (malyon-read-variable byte2)))))
(defun malyon-execute ()
"Execute z code instructions.
Load the next instruction opcode and its operands and execute it.
Repeat ad infinitum."
(let ((opcode) (operands)); (pc))
(while t
; (setq pc malyon-instruction-pointer)
(setq opcode (malyon-read-code-byte))
(setq operands (cond ((= opcode 190)
(setq opcode (+ 256 (malyon-read-code-byte)))
(malyon-fetch-extended opcode))
((>= opcode 192)
(malyon-fetch-variable opcode))
((>= opcode 128)
(malyon-fetch-short opcode))
(t
(malyon-fetch-long opcode))))
; (malyon-trace-opcode pc opcode operands)
(apply (aref malyon-opcodes opcode) operands))))
;; opcodes
(defsubst malyon-number (n)
"Convert an unsigned number into a signed one."
(if (< n 32768) n (- n 65536)))
(defun malyon-opcode-add (a b)
"Addition."
(malyon-store-variable (malyon-read-code-byte)
(+ (malyon-number a) (malyon-number b))))
(defun malyon-opcode-and (a b)
"Bitwise and."
(malyon-store-variable (malyon-read-code-byte) (logand a b)))
(defun malyon-opcode-aread (text parse &optional time routine)
"Read input text."
(setq malyon-aread-text text)
(setq malyon-aread-parse parse)
(goto-char (point-max))
(setq malyon-aread-beginning-of-line (point))
; Some games violate these assumptions for the "Quit" question.
; (if (> 3 (malyon-read-byte text))
; (malyon-fatal-error "text buffer less than 3 bytes."))
; (if (and (not (zerop parse)) (> 2 (malyon-read-byte parse)))
; (malyon-fatal-error "parse buffer less than 2 bytes."))
(malyon-more malyon-keymap-read)
(throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
(defun malyon-opcode-art-shift (value places)
"Arithmetic shift."
(malyon-store-variable (malyon-read-code-byte) (ash value places)))
(defun malyon-opcode-buffer-mode (mode)
"Toggles buffering of text in the transcript window."
(setq malyon-transcript-buffer-buffered (/= 0 mode)))
(defun malyon-opcode-calln (routine &rest arguments)
"Call a routine and ignore the result."
(malyon-call-routine routine arguments))
(defun malyon-opcode-calls (routine &rest arguments)
"Call a routine and store the result."
(malyon-call-routine routine arguments (malyon-read-code-byte)))
(defun malyon-opcode-catch ()
"Return the current stack frame."
(malyon-store-variable
(malyon-read-code-byte)
(if malyon-game-state-quetzal
(lsh (aref malyon-stack malyon-frame-pointer) -8)
malyon-frame-pointer)))
(defun malyon-opcode-check-arg-count (count)
"Tests the number of arguments passed to routine."
(malyon-jump-if
(<= count (logand 255 (aref malyon-stack
(if malyon-game-state-quetzal
(- malyon-frame-pointer 1)
malyon-frame-pointer))))))
(defun malyon-opcode-check-unicode (char)
"Check whether the given character is valid for input/output."
(malyon-store-variable (malyon-read-code-byte) 0))
(defun malyon-opcode-clear-attr (object attribute)
"Clear the given attribute in the given object."
(let ((attributes (malyon-object-address object))
(byte (lsh attribute -3)))
(malyon-store-byte (+ attributes byte)
(logand (malyon-read-byte (+ attributes byte))
(logxor (lsh 128 (- (logand attribute 7)))
255)))))
(defun malyon-opcode-copy-table (first second size)
"Copies first table onto second one."
(let* ((length (abs (malyon-number size)))
(zero (zerop second))
(forward (or (< (malyon-number size) 0) (> first second)))
(i 0)
(a (if forward first (+ first length -1)))
(b (if forward (if zero first second) (+ second length -1))))
(while (< i length)
(malyon-store-byte b (if zero 0 (malyon-read-byte a)))
(setq i (+ i 1)
a (if forward (+ a 1) (- a 1))
b (if forward (+ b 1) (- b 1))))))
(defun malyon-opcode-dec (var)
"Decrement variable."
(malyon-store-variable var
(- (malyon-number (malyon-read-variable var)) 1)))
(defun malyon-opcode-dec-chk (variable threshold)
"Decrement variable and jump if it's less than the given value."
(let ((value (malyon-number (malyon-read-variable variable))))
(malyon-store-variable variable (- value 1))
(malyon-jump-if (< (- value 1) (malyon-number threshold)))))
(defun malyon-opcode-div (a b)
"Division."
(if (zerop b) (malyon-fatal-error "division by 0."))
(malyon-store-variable (malyon-read-code-byte)
(/ (malyon-number a) (malyon-number b))))
(defun malyon-opcode-encode-text (text length from encoded)
"Encode the zscii text starting at from with the given length.
The result is stored at encoded."
(let* ((i length)
(j encoded)
(l '())
(word '()))
(while (< 0 i)
(setq l (cons (malyon-read-byte (+ text from i -1)) l)
i (- i 1)))
(setq word (malyon-encode-dictionary-word
(append (malyon-mapcan 'malyon-encode-into-ztext l)
'(5 5 5 5 5 5 5 5))))
(while (< i 6)
(malyon-store-byte j (car l))
(setq i (+ 1 i)
j (+ 1 j)
l (cdr word)))))
(defun malyon-opcode-erase-line (value)
"Erases the rest of the line."
(if (= value 1)
(if (eq malyon-transcript-buffer (current-buffer))
(kill-line nil)
(save-excursion
(let ((i (current-column)))
(while (<= i malyon-max-column)
(insert ? )
(delete-char 1)
(setq i (+ 1 i))))))))
(defun malyon-opcode-erase-window (window)
"Erase the contents of the given window."
(save-excursion
(let ((w (malyon-number window)))
(if (or (= w 0) (= w -1) (= w -2))
(malyon-erase-buffer malyon-transcript-buffer))
(if (or (= w 1) (= w -1) (= w -2))
(malyon-erase-buffer malyon-status-buffer))
(if (= w -1)
(malyon-split-buffer-windows 0)))
(setq malyon-last-cursor-position-after-input
(malyon-point-max malyon-transcript-buffer))))
(defun malyon-opcode-get-child (object)
"Get the first child of the given object and jump."
(let ((child (malyon-object-read-child (malyon-object-address object))))
(malyon-store-variable (malyon-read-code-byte) child)
(malyon-jump-if (/= 0 child))))
(defun malyon-opcode-get-cursor (array)
"Retrieves the current cursor position."
(save-excursion
(set-buffer malyon-status-buffer)
(malyon-store-word array (- (count-lines (point-min) (point)) 1))
(malyon-store-word (+ 2 array) (+ 1 (current-column)))))
(defun malyon-opcode-get-next-prop (object property)
"Retrieve the first or next property id of object."
(let ((next (malyon-first-property object))
(number 0))
(if (zerop property)
'()
(setq number (logand (malyon-read-byte next)
malyon-object-properties))
(setq next (malyon-next-property next))
(while (> number property)
(setq number (logand (malyon-read-byte next)
malyon-object-properties))
(setq next (malyon-next-property next)))
(if (/= number property)
(malyon-fatal-error "property does not exist.")))
(setq number (logand (malyon-read-byte next) malyon-object-properties))
(malyon-store-variable (malyon-read-code-byte) number)))
(defun malyon-opcode-get-parent (object)
"Get the parent of the given object."
(malyon-store-variable (malyon-read-code-byte)
(malyon-object-read-parent
(malyon-object-address object))))
(defun malyon-opcode-get-prop (object property)
"Get the value of the object's property."
(let* ((address (malyon-find-property object property))
(size (malyon-read-byte address)))
(malyon-store-variable
(malyon-read-code-byte)
(cond ((zerop address)
(malyon-read-word (+ malyon-object-table (* 2 (- property 1)))))
((and (< malyon-story-version 5) (zerop (lsh size -5)))
(malyon-read-byte (+ address 1)))
((and (>= malyon-story-version 5) (zerop (logand 192 size)))
(malyon-read-byte (+ address 1)))
(t
(malyon-read-word (+ address 1)))))))
(defun malyon-opcode-get-prop-addr (object property)
"Get the address of the object's property."
(let* ((address (malyon-find-property object property))
(size (malyon-read-byte address))
(offset (if (< malyon-story-version 5)
1
(if (zerop (logand 128 size)) 1 2))))
(malyon-store-variable (malyon-read-code-byte)
(if (zerop address) 0 (+ address offset)))))
(defun malyon-opcode-get-prop-len (property)
"Get the length of the object's property."
(let ((size (malyon-read-byte (- property 1))))
(malyon-store-variable
(malyon-read-code-byte)
(cond ((< malyon-story-version 5) (+ 1 (lsh size -5)))
((zerop (logand 128 size)) (+ 1 (lsh size -6)))
((zerop (logand 63 size)) 64)
(t (logand 63 size))))))
(defun malyon-opcode-get-sibling (object)
"Get the next object in the tree and jump."
(let ((sibling (malyon-object-read-sibling (malyon-object-address object))))
(malyon-store-variable (malyon-read-code-byte) sibling)
(malyon-jump-if (/= 0 sibling))))
(defun malyon-opcode-illegal (&rest ignore)
"Print an error message and exit the interpreter."
(malyon-fatal-error "illegal opcode."))
(defun malyon-opcode-inc (var)
"Increment variable."
(malyon-store-variable var
(+ (malyon-number (malyon-read-variable var)) 1)))
(defun malyon-opcode-inc-chk (variable threshold)
"Increment variable and jump if it's greater than the given value."
(let ((value (malyon-number (malyon-read-variable variable))))
(malyon-store-variable variable (+ value 1))
(malyon-jump-if (> (+ value 1) (malyon-number threshold)))))
(defun malyon-opcode-input-stream (number)
"Select the given input stream. Only the keyboard is supported."
(if (zerop (malyon-number number))
'()
(message "Only the keyboard is supported as an input stream.")))
(defun malyon-opcode-insert-obj (object destination)
"Insert an object into the children list of another."
(let ((child (malyon-object-address object))
(parent (malyon-object-address destination)))
(malyon-remove-object object)
(malyon-object-store-parent child destination)
(malyon-object-store-sibling child (malyon-object-read-child parent))
(malyon-object-store-child parent object)))
(defun malyon-opcode-je (a &rest rest)
"Jump if first operand equals any of the following."
(malyon-jump-if (member (malyon-number a) (mapcar 'malyon-number rest))))
(defun malyon-opcode-jg (a b)
"Jump if first operand > second operand."
(malyon-jump-if (> (malyon-number a) (malyon-number b))))
(defun malyon-opcode-jin (child parent)
"Jump if second object is parent of the first one."
(malyon-jump-if
(= parent (malyon-object-read-parent (malyon-object-address child)))))
(defun malyon-opcode-jl (a b)
"Jump if first operand < second operand."
(malyon-jump-if (< (malyon-number a) (malyon-number b))))
(defun malyon-opcode-jump (offset)
"Jump unconditionally."
(setq malyon-instruction-pointer (+ malyon-instruction-pointer
(malyon-number offset) -2)))
(defun malyon-opcode-jz (a)
"Jump if operand = 0."
(malyon-jump-if (zerop a)))
(defun malyon-opcode-load (variable)
"Load a variable."
(malyon-store-variable (malyon-read-code-byte)
(malyon-read-variable variable)))
(defun malyon-opcode-loadb (array index)
"Load an array element into a variable."
(malyon-store-variable (malyon-read-code-byte)
(malyon-read-byte (+ array index))))
(defun malyon-opcode-loadw (array index)
"Load an array element into a variable."
(malyon-store-variable (malyon-read-code-byte)
(malyon-read-word (+ array (* 2 index)))))
(defun malyon-opcode-log-shift (value places)
"Logical shift."
(malyon-store-variable (malyon-read-code-byte) (lsh value places)))
(defun malyon-opcode-mod (a b)
"Modulo."
(malyon-store-variable (malyon-read-code-byte)
(mod (malyon-number a) (malyon-number b))))
(defun malyon-opcode-mul (a b)
"Multiplication."
(malyon-store-variable (malyon-read-code-byte)
(* (malyon-number a) (malyon-number b))))
(defun malyon-opcode-new-line ()
"Print a newline."
(malyon-newline))
(defun malyon-opcode-nop (&rest ignore)
"Do nothing.")
(defun malyon-opcode-not (a)
"Bitwise not."
(malyon-store-variable (malyon-read-code-byte) (logand 65535 (lognot a))))
(defun malyon-opcode-or (a b)
"Bitwise or."
(malyon-store-variable (malyon-read-code-byte) (logior a b)))
(defun malyon-opcode-output-stream (stream &optional table)
"Select an output stream."
(let ((stream (malyon-number stream)))
(cond ((< 0 stream) (malyon-add-output-stream stream table))
((> 0 stream) (malyon-remove-output-stream (- stream))))))
(defun malyon-opcode-piracy ()
"Piracy check, effectively an unconditional jump."
(malyon-jump-if 1))
(defun malyon-opcode-pop ()
"Pop a value off the stack."
(malyon-pop-stack))
(defun malyon-opcode-print ()
"Print a string."
(setq malyon-instruction-pointer
(malyon-print-text malyon-instruction-pointer)))
(defun malyon-opcode-print-addr (address)
"Print a string."
(malyon-print-text address))
(defun malyon-opcode-print-char (c)
"Print a character."
(malyon-print (char-to-string c)))
(defun malyon-opcode-print-num (n)
"Print a number."
(malyon-print (number-to-string (malyon-number n))))
(defun malyon-opcode-print-obj (obj)
"Print the short name of the object."
(malyon-print-text
(+ 1 (malyon-read-word (+ malyon-object-property-offset
(malyon-object-address obj))))))
(defun malyon-opcode-print-paddr (address)
"Print a string."
(malyon-print-text (* malyon-packed-multiplier address)))
(defun malyon-opcode-print-ret ()
"Print a string, print a newline, return true/1."
(setq malyon-instruction-pointer
(malyon-print-text malyon-instruction-pointer))
(malyon-newline)
(malyon-return 1))
(defun malyon-opcode-print-table (text width &optional height skip)
"Print the given table."
(if (not height) (setq height 1))
(if (not skip) (setq skip 0))
(let ((column (current-column))
(address text)
(y 0)
(x 0))
(while (< y height)
(if (zerop y)
'()
(malyon-newline)
(malyon-print-characters (make-string column ? )))
(setq x 0)
(while (< x width)
(malyon-output-character (malyon-read-byte address))
(setq address (+ 1 address))
(setq x (+ 1 x)))
(setq address (+ skip address))
(setq y (+ 1 y)))))
(defun malyon-opcode-print-unicode (char)
"Prints a unicode character.")
(defun malyon-opcode-pull (variable)
"Pull value off stack."
(malyon-store-variable variable (malyon-pop-stack)))
(defun malyon-opcode-push (value)
"Push value onto stack."
(malyon-push-stack value))
(defun malyon-opcode-put-prop (object property value)
"Set the object's property to the given value."
(let* ((address (malyon-find-property object property))
(size (malyon-read-byte address)))
(cond ((= address 0)
(malyon-fatal-error "property does not exist."))
((and (< malyon-story-version 5) (zerop (lsh size -5)))
(malyon-store-byte (+ 1 address) (logand 255 value)))
((and (>= malyon-story-version 5) (zerop (logand size 192)))
(malyon-store-byte (+ 1 address) (logand 255 value)))
(t
(malyon-store-word (+ 1 address) value)))))
(defun malyon-opcode-quit ()
"End the game immediately."
(malyon-adjust-transcript)
(malyon-cleanup)
(throw 'malyon-end-of-interpreter-loop 'malyon-opcode-quit))
(defun malyon-opcode-random (limit)
"Generate a random number or set the seed value."
(malyon-store-variable (malyon-read-code-byte)
(if (>= 0 (malyon-number limit))
0
(+ 1 (random (malyon-number limit))))))
(defun malyon-opcode-read-char (&optional device &rest ignore)
"Read a character."
(if (and device (/= 1 device))
(malyon-fatal-error "illegal device specified in read_char."))
(if (eq malyon-transcript-buffer (current-buffer))
(goto-char (point-max)))
(message "[Press a key.]")
(malyon-more malyon-keymap-readchar)
(throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-character))
(defun malyon-opcode-remove-obj (object)
"Remove an object from its parent's children list."
(malyon-remove-object object))
(defun malyon-opcode-restart ()
"Restart the game."
(malyon-set-game-state malyon-game-state-restart))
(defun malyon-opcode-restore (&optional table bytes name)
"Restore a saved game state or a section of memory from a file."
(let ((result (if name
(malyon-restore-file
(malyon-get-file-name name) table bytes)
(call-interactively 'malyon-restore-file))))
(if (< malyon-story-version 5)
(malyon-jump-if (not (zerop result)))
(malyon-store-variable (malyon-read-code-byte) result))))
(defun malyon-opcode-restore-undo ()
"Restore game state for undo."
(if malyon-game-state-undo
(malyon-set-game-state malyon-game-state-undo))
(malyon-store-variable (malyon-read-code-byte) 2))
(defun malyon-opcode-ret (value)
"Return a value."
(malyon-return value))
(defun malyon-opcode-ret-popped ()
"Return top of stack."
(malyon-return (malyon-pop-stack)))
(defun malyon-opcode-rfalse ()
"Return false/0."
(malyon-return 0))
(defun malyon-opcode-rtrue ()
"Return true/1."
(malyon-return 1))
(defun malyon-opcode-save (&optional table bytes name)
"Save the current game state or a section of memory to a file."
(let ((result (if name
(malyon-save-file (malyon-get-file-name name) table bytes)
(call-interactively 'malyon-save-file))))
(if (< malyon-story-version 5)
(malyon-jump-if (not (zerop result)))
(malyon-store-variable (malyon-read-code-byte) result))))
(defun malyon-opcode-save-undo ()
"Save game state for undo."
(setq malyon-game-state-undo (malyon-current-game-state))
(malyon-store-byte (malyon-read-code-byte) 1))
(defun malyon-opcode-scan-table (x table len &optional form)
"Scan the given table for the first occurrence of x."
(if (not form) (setq form 130))
(let ((inc (logand 127 form))
(byte (zerop (logand 128 form)))
(addr table)
(found 0)
(index 0))
(while (and (zerop found) (< index len))
(setq found
(if byte
(if (= x (malyon-read-byte addr)) addr 0)
(if (= x (malyon-read-word addr)) addr 0)))
(setq addr (+ addr inc))
(setq index (+ index 1)))
(malyon-store-variable (malyon-read-code-byte) found)
(malyon-jump-if (not (zerop found)))))
(defun malyon-opcode-set-attr (object attribute)
"Set the given attribute in the given object."
(let ((attributes (malyon-object-address object))
(byte (lsh attribute -3)))
(malyon-store-byte (+ attributes byte)
(logior (malyon-read-byte (+ attributes byte))
(lsh 128 (- (logand attribute 7)))))))
(defun malyon-opcode-set-color (foreground background)
"Sets the fore- and background colors ie. does nothing.")
(defun malyon-opcode-set-cursor (&optional line column)
"Set the cursor."
(if (eq malyon-transcript-buffer (current-buffer))
(goto-char (point-max))
(if malyon-status-buffer-delayed-split
(progn
(malyon-split-buffer-windows malyon-status-buffer-delayed-split)
(other-window 1)))
(if line '() (setq line (count-lines (point-min) (point))))
(if column '() (setq column (current-column)))
(if (> line malyon-status-buffer-lines)
(progn
(malyon-split-buffer-windows line)
(other-window 1)))
(goto-char (point-min))
(if (and (<= 1 line) (<= line malyon-status-buffer-lines))
(forward-line line)
(beginning-of-line))
(if (and (<= 1 column) (<= column malyon-max-column))
(forward-char (- column 1))
(beginning-of-line))
(setq malyon-status-buffer-point (point))))
(defun malyon-opcode-set-font (font)
"Sets the font if available or 0 otherwise."
(malyon-store-variable (malyon-read-code-byte) 0))
(defun malyon-opcode-set-text-style (style)
"Set the text style/face."
(let ((face (assq style malyon-faces)))
(setq malyon-current-face (if face (cdr face) 'malyon-face-plain))))
(defun malyon-opcode-set-window (window)
"Set the current window."
(malyon-restore-window-configuration)
(setq malyon-current-window window)
(malyon-update-output-streams)
(if (zerop window)
(if (not (eq malyon-transcript-buffer (current-buffer)))
(other-window 1))
(if (not (eq malyon-status-buffer (current-buffer)))
(other-window 1))
(malyon-opcode-set-cursor 1 1)))
(defun malyon-opcode-show-status ()
"Display the status line."
(save-excursion
(malyon-opcode-split-window 1)
(malyon-restore-window-configuration)
(malyon-opcode-set-window 1)
(malyon-prepare-status-buffer 1)
(malyon-opcode-set-cursor 1 1)
(malyon-opcode-print-obj (malyon-read-global-variable 0))
(if (<= (current-column) (- (current-fill-column) 10))
(let* ((x (malyon-read-global-variable 1))
(y (malyon-read-global-variable 2))
(hours (if (> x 12) (- x 12) x))
(ampm (if (> x 12) "PM" "AM"))
(score (format "%4d/%4d" x y))
(time (format "%02d:%02d%s" hours y ampm)))
(malyon-opcode-set-cursor 1 (- (current-fill-column) 10))
(malyon-print (if malyon-score-game score time))))
(malyon-opcode-set-window 0)
(malyon-adjust-transcript)))
(defun malyon-opcode-split-window (size)
"Split upper and lower window."
(malyon-set-window-configuration size))
(defun malyon-opcode-store (variable value)
"Store a value in a variable."
(malyon-store-variable variable value))
(defun malyon-opcode-storeb (array index value)
"Store a value in an array at the given index."
(malyon-store-byte (+ array index) value))
(defun malyon-opcode-storew (array index value)
"Store a value in an array at the given index."
(malyon-store-word (+ array (* 2 index)) value))
(defun malyon-opcode-sub (a b)
"Subtraction."
(malyon-store-variable (malyon-read-code-byte)
(- (malyon-number a) (malyon-number b))))
(defun malyon-opcode-test (bitmap flags)
"Test if all of the flags are set in the bitmap."
(malyon-jump-if (= flags (logand bitmap flags))))
(defun malyon-opcode-test-attr (object attribute)
"Jump depending on the given attribute in the given object."
(malyon-jump-if
(/= 0 (logand (malyon-read-byte (+ (malyon-object-address object)
(lsh attribute -3)))
(lsh 128 (- (logand attribute 7)))))))
(defun malyon-opcode-throw (value frame)
"Return from the given stack frame."
(if malyon-game-state-quetzal
(let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
(while (/= frame id)
(setq malyon-stack-pointer malyon-frame-pointer)
(malyon-pop-stack)
(setq malyon-frame-pointer
(- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
(malyon-pop-stack)
(malyon-pop-stack)
(setq id (lsh (aref malyon-stack malyon-frame-pointer) -8))))
(setq malyon-frame-pointer frame))
(malyon-return value))
(defun malyon-opcode-tokenise (text parse &optional dict flag)
"Perform lexical analysis on the text buffer."
(let* ((words (malyon-text-to-words text dict))
(word (car words))
(start (car word))
(len (malyon-cadr word))
(code (malyon-caddr word))
(entry (malyon-lookup dict code))
(i 0))
(while (not (or (null words) (= i (malyon-read-byte parse))))
(if (and (zerop entry) flag (/= 0 flag))
'()
(malyon-store-word (+ 2 parse (* 4 i)) entry)
(malyon-store-byte (+ 4 parse (* 4 i)) len)
(malyon-store-byte (+ 5 parse (* 4 i)) start))
(setq words (cdr words)
word (car words)
start (car word)
len (malyon-cadr word)
code (malyon-caddr word)
entry (malyon-lookup dict code)
i (+ 1 i)))
(malyon-store-byte (+ 1 parse) i)))
(defun malyon-opcode-verify ()
"Verify the correctness of the story file."
(let ((length (+ 1 (* malyon-packed-multiplier (malyon-read-word 26))))
(sum 0)
(i 64))
(while (< i length)
(setq sum (mod (+ sum (malyon-read-byte i)) 65536)
i (+ 1 i)))
(malyon-jump-if (= (malyon-read-word 28) sum))))
;; keymap utilities
(defun malyon-end-input ()
"Store the input line in a text buffer and perform lexical analysis."
(interactive)
(condition-case nil
(progn
(malyon-adjust-transcript)
(switch-to-buffer malyon-transcript-buffer)
(goto-char (point-max))
(let* ((input (downcase
(buffer-substring-no-properties
(if (< malyon-aread-beginning-of-line (point))
malyon-aread-beginning-of-line
(point))
(point))))
(vec (malyon-string-to-vector input))
(text (apply 'vector (mapcar 'malyon-unicode-to-zscii vec)))
(len (min (malyon-read-byte malyon-aread-text) (length text)))
(i 0))
(malyon-history-insert input)
(if (>= malyon-story-version 5)
(malyon-store-byte (+ malyon-aread-text 1) len))
(while (< i len)
(malyon-store-byte
(+ malyon-aread-text (if (< malyon-story-version 5) 1 2) i)
(malyon-char-to-int (aref text i)))
(setq i (+ 1 i)))
(if (< malyon-story-version 5)
(malyon-store-byte (+ malyon-aread-text 1 len) 0)))
(if (/= 0 malyon-aread-parse)
(malyon-opcode-tokenise malyon-aread-text malyon-aread-parse))
(newline)
(if (>= malyon-story-version 5)
(malyon-store-variable (malyon-read-code-byte) 10))
(malyon-interpreter))
(error
(malyon-fatal-error "unspecified internal runtime error."))))
(defun malyon-more-char ()
"Page down in More mode."
(interactive)
(condition-case nil
(scroll-up)
(error))
(if (>= (count-lines (point) (point-max))
(malyon-window-displayed-height))
(message "[More]")
(goto-char (point-max))
(malyon-adjust-transcript)
(use-local-map malyon-more-continue-keymap)))
(defun malyon-more-char-status ()
"Wait for a key then continue."
(interactive)
(condition-case nil
(progn
(malyon-adjust-transcript)
(use-local-map malyon-more-continue-keymap)
(malyon-interpreter))
(error
(malyon-fatal-error "unspecified internal runtime error."))))
(defun malyon-wait-char ()
"Store the input character in a variable and resume execution."
(interactive)
(condition-case nil
(progn
(malyon-store-variable
(malyon-read-code-byte)
(malyon-char-to-int (malyon-unicode-to-zscii last-command-char)))
(use-local-map malyon-keymap-read)
(malyon-interpreter))
(error
(malyon-fatal-error "unspecified internal runtime error."))))
(defun malyon-history-previous-char (arg)
"Display the previous item in the input history."
(interactive "p")
(let ((input (malyon-history-previous)))
(cond ((> malyon-aread-beginning-of-line (point))
(funcall malyon-history-saved-up arg))
(input
(save-excursion
(set-buffer malyon-transcript-buffer)
(delete-region malyon-aread-beginning-of-line (point-max)))
(goto-char (point-max))
(insert input)
(malyon-adjust-transcript)))))
(defun malyon-history-next-char (arg)
"Display the next item in the input history."
(interactive "p")
(let ((input (malyon-history-next)))
(cond ((> malyon-aread-beginning-of-line (point))
(funcall malyon-history-saved-down arg))
(input
(save-excursion
(set-buffer malyon-transcript-buffer)
(delete-region malyon-aread-beginning-of-line (point-max)))
(goto-char (point-max))
(insert input)
(malyon-adjust-transcript)))))
(defun malyon-beginning-of-line (arg)
"Go to the beginning of the line."
(interactive "p")
(if (> malyon-aread-beginning-of-line (point))
(beginning-of-line)
(goto-char malyon-aread-beginning-of-line)))
(defun malyon-kill-region (arg)
"Kill region."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(kill-region (point) (mark))
(message "Editing is restricted to the input prompt.")))
(defun malyon-kill-line (arg)
"Kill rest of the current line."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(kill-line)
(message "Editing is restricted to the input prompt.")))
(defun malyon-kill-word (arg)
"Kill the current word."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(kill-word 1)
(message "Editing is restricted to the input prompt.")))
(defun malyon-yank (arg)
"Yank."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(yank)
(message "Editing is restricted to the input prompt.")))
(defun malyon-yank-pop (arg)
"Yank pop."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(yank-pop 1)
(message "Editing is restricted to the input prompt.")))
(defun malyon-delete-char (arg)
"Delete a character."
(interactive "p")
(if (<= malyon-aread-beginning-of-line (point))
(delete-char 1)
(message "Editing is restricted to the input prompt.")))
(defun malyon-backward-delete-char (arg)
"Delete a character backwards."
(interactive "p")
(if (< malyon-aread-beginning-of-line (point))
(backward-delete-char-untabify 1)
(message "Editing is restricted to the input prompt.")))
(defun malyon-self-insert-command (arg)
"Insert a character."
(interactive "p")
(if (> malyon-aread-beginning-of-line (point))
(goto-char (point-max)))
(self-insert-command 1))
;; tracing utility
(defun malyon-trace-file ()
"Turn tracing on for a particular file."
(let ((trace
(get-buffer-create
(concat "Malyon Trace " malyon-story-file-name))))
(if trace
(save-excursion
(set-buffer trace)
(malyon-erase-buffer)
(insert (concat "Tracing " malyon-story-file-name "..."))
(newline)))))
(defun malyon-trace-newline ()
"Output tracing newline."
(let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
(if trace
(save-excursion
(set-buffer trace)
(goto-char (point-max))
(newline)))))
(defun malyon-trace-opcode (pc opcode operands)
"Output a z code instruction."
(malyon-trace-string
(format "%8d %-3d %-25s %s\n"
pc
opcode
(symbol-name (aref malyon-opcodes opcode))
(apply 'concat (malyon-mapcan
(lambda (x)
(list " "
(number-to-string
(if (malyon-characterp x)
(malyon-char-to-int x)
x))))
operands)))))
(defun malyon-trace-string (s)
"Output tracing string."
(let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
(if (and trace s)
(save-excursion
(set-buffer trace)
(goto-char (point-max))
(insert s)))))
(defun malyon-trace-object (o)
"Output tracing object."
(let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
(if (and trace o)
(save-excursion
(set-buffer trace)
(goto-char (point-max))
(prin1 o trace)))))
;;; announce malyon-mode
(provide 'malyon-mode)
(provide 'malyon)
;;; malyon-mode.el ends here
