; malyon-mode.el --- mode to execute z code files version 3, 5, 8
;; Copyright (C) 1999, 2000 Peter Ilberg
;; Maintainer: Peter Ilberg <
[email protected]>
;; Credits: z8 support by Alberto Petrofsky <
[email protected]>
;;; 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.
;; 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.
;; Enjoy!
;;; Code:
;; 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 (malyon-read-byte 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."
(message "Use M-x malyon if you want to play a zcode game."))
;; compatibility functions for GNU emacs
(defun malyon-cadr (list)
"Take the cadr of the list."
(fset 'malyon-cadr
(condition-case nil (progn (symbol-function 'cadr) 'cadr)
(error (lambda (list) (car (cdr list))))))
(malyon-cadr list))
(defun malyon-caddr (list)
"Take the caddr of the list."
(fset 'malyon-caddr
(condition-case nil (progn (symbol-function 'caddr) 'caddr)
(error (lambda (list) (car (cdr (cdr list)))))))
(malyon-caddr list))
(defun malyon-cdddr (list)
"Take the cdddr of the list."
(fset 'malyon-cdddr
(condition-case nil (progn (symbol-function 'cdddr) 'cdddr)
(error (lambda (list) (cdr (cdr (cdr list)))))))
(malyon-cdddr list))
(defun malyon-char-before ()
"Return the character before the point."
(fset 'malyon-char-before
(condition-case nil
(progn (symbol-function 'char-before) 'char-before)
(error (lambda () (char-after (- (point) 1))))))
(malyon-char-before))
(defun malyon-char-to-int (c)
"Convert a character into an integer."
(fset 'malyon-char-to-int
(condition-case nil
(progn (symbol-function 'char-to-int) 'char-to-int)
(error (lambda (c) c))))
(malyon-char-to-int c))
(defun malyon-characterp (x)
"Test for a character."
(fset 'malyon-characterp
(condition-case nil
(progn (symbol-function 'characterp) 'characterp)
(error (lambda (x) (and (numberp x) (<= 0 x) (< x 256))))))
(malyon-characterp x))
(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))
(erase-buffer)))
(defun malyon-mapc (function list)
"Apply fun to every element of args ignoring the results."
(fset 'malyon-mapc
(condition-case nil
(progn (symbol-function 'mapc) 'mapc)
(error (lambda (function list)
(if (null list)
'()
(funcall function (car list))
(malyon-mapc function (cdr list)))))))
(malyon-mapc function list))
(defun malyon-mapcan (function list)
"Apply fun to every element of args nconc'ing the result."
(fset 'malyon-mapcan
(condition-case nil
(progn (symbol-function 'mapcan) 'mapcan)
(error (lambda (function list)
(if (null list)
'()
(nconc (funcall function (car list))
(malyon-mapcan function (cdr list))))))))
(malyon-mapcan function list))
(defun malyon-point-max (&optional buffer)
"Get the point-max of the given buffer."
(save-excursion
(if buffer (set-buffer buffer))
(point-max)))
(defun malyon-redisplay-frame (frame &rest ignore)
"Redisplay the given frame."
(fset 'malyon-redisplay-frame
(condition-case nil
(progn (symbol-function 'redisplay-frame) 'redisplay-frame)
(error (lambda (frame &rest ignore)))))
(malyon-redisplay-frame frame ignore))
(defun malyon-remove (element list)
"Remove the element from the list."
(fset 'malyon-remove
(condition-case nil
(progn (symbol-function 'remove) 'remove)
(error (lambda (element 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)))))))))
(malyon-remove element list))
(defun malyon-set-keymap-name (keymap name)
"Set the name of the keymap."
(fset 'malyon-set-keymap-name
(condition-case nil
(progn (symbol-function 'set-keymap-name) 'set-keymap-name)
(error (lambda (keymap name)))))
(malyon-set-keymap-name keymap name))
(defun malyon-string-to-list (s)
"Convert a string into a list of characters."
(fset 'malyon-string-to-list
(condition-case nil
(progn (symbol-function 'string-to-list) 'string-to-list)
(error (lambda (s)
(let ((i (- (length s) 1)) (l '()))
(while (<= 0 i)
(setq l (cons (aref s i) l)
i (- i 1)))
l)))))
(malyon-string-to-list s))
(defun malyon-string-to-vector (s)
"Convert a string into a vector of characters."
(fset 'malyon-string-to-vector
(condition-case nil
(progn (symbol-function 'string-to-vector) 'string-to-vector)
(error (lambda (s)
(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)))))
(malyon-string-to-vector s))
(defun malyon-window-displayed-height (&optional window)
"Get the height of the window's displayed region."
(fset 'malyon-window-displayed-height
(condition-case nil
(progn (symbol-function 'window-displayed-height)
'window-displayed-height)
(error (lambda (&optional window) (- (window-height) 1)))))
(malyon-window-displayed-height window))
(defun malyon-yes-or-no-p-minibuf (prompt)
"Ask a yes or no question."
(fset 'malyon-yes-or-no-p-minibuf
(condition-case nil
(progn (symbol-function 'yes-or-no-p-minibuf)
'yes-or-no-p-minibuf)
(error (lambda (prompt) (yes-or-no-p prompt)))))
(malyon-yes-or-no-p-minibuf 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 (copy-keymap (current-global-map)))
(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))
(defvar malyon-keymap-readchar nil
"Keymap for malyon mode for waiting for input.")
(if malyon-keymap-readchar
'()
(setq malyon-keymap-readchar (copy-keymap (current-global-map)))
(malyon-set-keymap-name malyon-keymap-readchar 'malyon-keymap-readchar)
(define-key malyon-keymap-readchar "\r" 'malyon-wait-char)
(substitute-key-definition (lookup-key malyon-keymap-readchar "a")
'malyon-wait-char
malyon-keymap-readchar))
(defvar malyon-keymap-more nil
"Keymap for malyon mode for browsing through text.")
(if malyon-keymap-more
'()
(setq malyon-keymap-more (copy-keymap (current-global-map)))
(malyon-set-keymap-name malyon-keymap-more 'malyon-keymap-more)
(define-key malyon-keymap-more "\r" 'malyon-more-char)
(substitute-key-definition (lookup-key malyon-keymap-more "a")
'malyon-more-char
malyon-keymap-more))
(defvar malyon-faces nil
"An association list of text faces used by the malyon mode.")
(if malyon-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))))
;; 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."
(cond ((= var 0) (malyon-push-stack value))
((< var 16) (malyon-store-local-variable var value))
(t (malyon-store-global-variable (- var 16) value))))
;; 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)
(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 71)
(malyon-store-word 34 71)
(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)
(setq malyon-frame-pointer -1)
(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)))))
(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)
(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 0.5")
(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, 2000 by Peter Ilberg <
[email protected]>")
(malyon-newline)
(malyon-print "Z8 support by Alberto Petrofsky ")
(malyon-print "<
[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)))
(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-string message)
(newline))
(malyon-cleanup)
(malyon-redisplay-frame (selected-frame) t)
(error message)))
;; malyon game file related global variables
(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.")
(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-object-table nil
"A pointer to the object table 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-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.")
(defvar malyon-whitespace nil
"A string of whitespace characters recognized by the interpreter.")
(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))))
;; 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))))
(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."
(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
(defvar malyon-current-face nil
"The current face in which to display 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 ?\n)
(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))
(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 char 1))
(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 char 1)
(delete-char 1))))
(defun malyon-putchar-table (char table)
"Print a single character into a table."
(malyon-store-byte (+ 2 table (malyon-read-word table))
(if (char-equal char ?\n) 13 char))
(malyon-store-word table (+ 1 (malyon-read-word table))))
;; more
(defvar malyon-last-cursor-position-after-input nil
"The last cursor position after reading input from the keyboard.")
(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]"))))
;; 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-window-configuration nil
"The current window configuration of the malyon interpreter.")
(defvar malyon-current-window nil
"The currently active window for text output.")
(defvar malyon-transcript-buffer nil
"The main transcript buffer of the story file execution.")
(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).")
(defun malyon-adjust-transcript ()
"Adjust the position of the transcript text."
(save-excursion
(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)
(malyon-erase-buffer)
(newline 1)
(while (> status 0)
(insert-string (make-string (+ 3 malyon-max-column) ? ))
(newline 1)
(setq status (- status 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))
((> status malyon-status-buffer-lines)
(malyon-split-buffer-windows status))
((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
(defvar malyon-game-state-restart nil
"The machine state for implementing restart.")
(defvar malyon-game-state-undo nil
"The machine state for implementing undo.")
(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)))
(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))))
;; 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-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)))
(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)
(if table
(malyon-save-table table length)
(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)))))
;; restoring data from disk
(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
(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)
(malyon-restore-game-state))
(kill-buffer nil)
2)
(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)
(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)))
(if (string= name malyon-story-file-name)
(malyon-set-game-state (vector ip sp fp stack mem))
(message "Invalid save file."))))
;; object table management
(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.")
(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)
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-frame-pointer malyon-stack-pointer)
(setq malyon-instruction-pointer (* malyon-packed-multiplier routine))
(let ((args (malyon-read-code-byte))
(value nil))
(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)
(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))
;; other stuff
(defvar malyon-transcript-buffer-buffered nil
"Is output in the transcript buffer buffered?")
(defvar malyon-status-buffer-point nil
"The point location in the status bar buffer.")
(defvar malyon-max-column 72
"Maximum column for text display.")
(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.")
;; 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.")
;; 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 '()))
(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 (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))))
;; 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.")
;; 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))
(if (> 3 (malyon-read-byte text))
(malyon-fatal-error "text buffer less than 3 bytes."))
(if (and parse (> 6 (malyon-read-byte parse)))
(malyon-fatal-error "parse buffer less than 6 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) 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 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-char ? 1)
(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-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 (device &rest ignore)
"Read a character."
(if (/= 1 device)
(malyon-fatal-error "illegal device specified in read_char."))
(if (eq malyon-transcript-buffer (current-buffer))
(goto-char (point-max)))
(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)
(malyon-opcode-erase-window -1))
(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) 0)))
(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) 0))
(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))
(while (and (zerop found) (< addr (+ table 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)))
(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 (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)))
(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."
(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))))
(text (malyon-string-to-vector input))
(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
(progn
(scroll-up)
(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)))
(error
(malyon-fatal-error "more mode failed."))))
(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 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-string 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-string input)
(malyon-adjust-transcript)))))
;; 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-string (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-string 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
