emacs/malyon.el

   1 ; malyon.el --- mode to execute z code files version 3, 5, 8
   2
   3 ;; Copyright (C) 1999-2009 Peter Ilberg
   4
   5 ;; Maintainer: Peter Ilberg <peter.ilberg@gmail.com>
   6
   7 ;; Credits:
   8 ;;   The author would like to thank the following people for reporting
   9 ;;   bugs, testing, suggesting and/or contributing improvements:
  10 ;;     Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko
  11
  12 ;;; Commentary:
  13
  14 ;; This package provides a basic interpreter for version 3, 5, 8 z code
  15 ;; story files as generated by Inform (C) Graham Nelson and Infocom.
  16
  17 ;; If you encounter a bug please send a report to Peter Ilberg at
  18 ;; peter.ilberg@gmail.com. Thank you!
  19
  20 ;; To play a story file simple type M-x malyon and enter the path to the
  21 ;; story file. If anything goes wrong and you want to manually clean
  22 ;; up type M-x malyon-quit. In addition, you can switch back to a game in
  23 ;; progress by typing M-x malyon-restore.
  24
  25 ;; A note on the format of saved game states:
  26
  27 ;; As of version 1.0, Malyon supports the quetzal file format for saved
  28 ;; games. Support for this format required changes to several internal
  29 ;; data structures (stack frames and catch-throw) that are incompatible
  30 ;; with the old implementation. Unfortunately, the old file format for
  31 ;; saved games cannot be converted into quetzal.
  32
  33 ;; For backwards compatibility, however, Malyon still supports the old
  34 ;; file format. And you can continue to play your old game states.
  35
  36 ;; Because of the incompatibility of the two file formats, Malyon now
  37 ;; runs, as follows, in either of two modes: quetzal and compatibility.
  38
  39 ;; - in quetzal mode, game states are saved in quetzal format
  40 ;; - in compatibility mode, games states are saved in the old format
  41 ;; - loading a game state in quetzal format switches to quetzal mode
  42 ;; - loading an old game state switches to compatibility mode
  43 ;; - quetzal mode is the default setting
  44
  45 ;; In other words, Malyon will only use the old file format if you've
  46 ;; restored a game state saved in the old file format.
  47
  48 ;; Enjoy!
  49
  50 ;;; Code:
  51
  52 ;; global variables - moved here to appease the byte-code compiler
  53
  54 ;; story file information
  55
  56 (defvar malyon-story-file-name nil
  57   "The name of the story file being executed.")
  58
  59 (defvar malyon-story-file nil
  60   "The story file which is currently being run.")
  61
  62 (defvar malyon-story-version nil
  63   "The story file version.")
  64
  65 (defvar malyon-supported-versions '(3 5 8)
  66   "A list of supported story file versions.")
  67
  68 ;; status and transcript buffers
  69
  70 (defvar malyon-transcript-buffer nil
  71   "The main transcript buffer of the story file execution.")
  72
  73 (defvar malyon-transcript-buffer-buffered nil
  74   "Is output in the transcript buffer buffered?")
  75
  76 (defvar malyon-status-buffer nil
  77   "The status bar buffer of the story file execution.")
  78
  79 (defvar malyon-status-buffer-lines nil
  80   "The number of lines in the status bar buffer.")
  81
  82 (defvar malyon-status-buffer-delayed-split nil
  83   "If the number of lines in the status buffer is reduced,
  84 the window configuration is not changed immediately. It
  85 is changed after the next turn (read or read_char).")
  86
  87 (defvar malyon-status-buffer-point nil
  88   "The point location in the status bar buffer.")
  89
  90 (defvar malyon-max-column 72
  91   "Maximum column for text display.")
  92
  93 ;; window management
  94
  95 (defvar malyon-window-configuration nil
  96   "The current window configuration of the malyon interpreter.")
  97
  98 (defvar malyon-current-window nil
  99   "The currently active window for text output.")
 100
 101 ;; z machine registers
 102
 103 (defvar malyon-stack nil
 104   "The stack of the z machine.")
 105
 106 (defvar malyon-stack-pointer nil
 107   "The stack pointer of the z machine.")
 108
 109 (defvar malyon-frame-pointer nil
 110   "The frame pointer of the z machine.")
 111
 112 (defvar malyon-instruction-pointer nil
 113   "The instruction pointer of the z machine.")
 114
 115 ;; game file related global variables
 116
 117 (defvar malyon-score-game nil
 118   "A flag indicating whether this story uses score or time.")
 119
 120 (defvar malyon-packed-multiplier nil
 121   "The amount by which packed addresses are multiplied to get byte
 122 addresses.")
 123
 124 (defvar malyon-global-variables nil
 125   "A pointer to the global variable section in the story file.")
 126
 127 (defvar malyon-abbreviations nil
 128   "A pointer to the abbreviations in the story file.")
 129
 130 (defvar malyon-alphabet nil
 131   "The z machine's text alphabet.")
 132
 133 (defvar malyon-whitespace nil
 134   "A string of whitespace characters recognized by the interpreter.")
 135
 136 ;; object tables
 137
 138 (defvar malyon-object-table nil
 139   "A pointer to the object table in the story file.")
 140
 141 (defvar malyon-object-table-entry-size nil
 142   "The size of one entry in the object table.")
 143
 144 (defvar malyon-object-properties nil
 145   "The number of properties per object minus one.")
 146
 147 (defvar malyon-object-property-offset nil
 148   "The byte offset of the properties table in the object.")
 149
 150 ;; dictionaries
 151
 152 (defvar malyon-dictionary nil
 153   "A pointer to the dictionary of the story file.")
 154
 155 (defvar malyon-dictionary-entry-length nil
 156   "The length of a dictionary entry.")
 157
 158 (defvar malyon-dictionary-num-entries nil
 159   "The number of dictionary entries.")
 160
 161 (defvar malyon-dictionary-entries nil
 162   "A pointer to the first dictionary entry.")
 163
 164 (defvar malyon-dictionary-word-length nil
 165   "The length of a dictionary word.")
 166
 167 ;; game state information
 168
 169 (defvar malyon-game-state-restart nil
 170   "The machine state for implementing restart.")
 171
 172 (defvar malyon-game-state-undo nil
 173   "The machine state for implementing undo.")
 174
 175 (defvar malyon-game-state-quetzal t
 176   "Store game state information for quetzal.")
 177
 178 ;; various
 179
 180 (defvar malyon-current-face nil
 181   "The current face in which to display text.")
 182
 183 (defvar malyon-last-cursor-position-after-input nil
 184   "The last cursor position after reading input from the keyboard.")
 185
 186 ;; interactive functions
 187
 188 (defun malyon (file-name)
 189   "Major mode for playing z3/5/8 story files.
 190 This mode allows execution of version 3, 5, 8 z code story files."
 191   (interactive "fStory file name: ")
 192   (if malyon-story-file
 193       (message "You are already playing a game.")
 194     (if (not (string-match ".*\.z[358]$" file-name))
 195         (message "%s is not a version 3, 5, or 8 story file." file-name)
 196       (condition-case nil
 197           (malyon-load-story-file file-name)
 198         (error
 199          (malyon-fatal-error "loading of story file failed.")))
 200       (setq malyon-story-version (aref malyon-story-file 0))
 201       (cond ((memq malyon-story-version malyon-supported-versions)
 202              (condition-case nil
 203                  (malyon-initialize)
 204                (error
 205                 (malyon-fatal-error "initialization of interpreter failed.")))
 206              (malyon-interpreter))
 207             (t
 208              (message "%s is not a version 3, 5, or 8 story file." file-name)
 209              (malyon-cleanup))))))
 210
 211 (defun malyon-restore ()
 212   "Restore the save window configuration for the interpreter."
 213   (interactive)
 214   (condition-case nil
 215       (progn
 216         (malyon-restore-window-configuration)
 217         (malyon-adjust-transcript))
 218     (error
 219      (malyon-fatal-error "restoring window configuration failed."))))
 220
 221 (defun malyon-quit ()
 222   "Exit the malyon interpreter."
 223   (interactive)
 224   (if malyon-story-file
 225       (progn
 226         (malyon-restore)
 227         (if (malyon-yes-or-no-p-minibuf "Do you really want to quit? ")
 228             (malyon-cleanup)))))
 229
 230 (defun malyon-mode ()
 231   "This mode provides a basic interpreter for version 3, 5, 8 z code
 232 story files as generated by Inform (C) Graham Nelson and Infocom.
 233
 234 Note that this package is by no means complete and bug free.
 235 If you encounter a bug please send a report to Peter Ilberg at
 236 peter.ilberg@natinst.com. Thank you!
 237
 238 To play a story file simple type M-x malyon and enter the path to the
 239 story file. If anything goes wrong and you want to manually clean
 240 up type M-x malyon-quit. In addition, you can switch back to a game in
 241 progress by typing M-x malyon-restore.
 242
 243 The author would like to thank the following people for reporting
 244 bugs, testing, suggesting and/or contributing improvements:
 245     Bernhard Barde, Jonathan Craven, Alberto Petrofsky, Alan Shutko"
 246   (message "Use M-x malyon if you want to play a zcode game."))
 247
 248 ;; compatibility functions for GNU emacs
 249
 250 (if (fboundp 'cadr)
 251     (defalias 'malyon-cadr 'cadr)
 252   (defun malyon-cadr (list)
 253     "Take the cadr of the list."
 254     (car (cdr list))))
 255
 256 (if (fboundp 'caddr)
 257     (defalias 'malyon-caddr 'caddr)
 258   (defun malyon-caddr (list)
 259     "Take the caddr of the list."
 260     (car (cdr (cdr list)))))
 261
 262 (if (fboundp 'cdddr)
 263     (defalias 'malyon-cdddr 'cdddr)
 264   (defun malyon-cdddr (list)
 265     "Take the cdddr of the list."
 266     (cdr (cdr (cdr list)))))
 267
 268 (if (fboundp 'char-before)
 269     (defalias 'malyon-char-before 'char-before)
 270   (defun malyon-char-before ()
 271     "Return the character before the point."
 272     (char-after (- (point) 1))))
 273
 274 (if (fboundp 'char-to-int)
 275     (defalias 'malyon-char-to-int 'char-to-int)
 276   (defun malyon-char-to-int (c)
 277     "Convert a character into an integer."
 278     c))
 279
 280 (if (fboundp 'characterp)
 281     (defalias 'malyon-characterp 'characterp)
 282   (defun malyon-characterp (x)
 283     "Test for a character."
 284     (and (numberp x) (<= 0 x) (< x 256))))
 285
 286 (defun malyon-disable-multibyte ()
 287   "Disable multibyte support in the current buffer."
 288   (condition-case nil (set-buffer-multibyte nil) (error)))
 289
 290 (defun malyon-erase-buffer (&optional buffer)
 291   "Erase the given buffer."
 292   (save-excursion
 293     (if buffer (set-buffer buffer))
 294     (if (and buffer (eq buffer malyon-transcript-buffer))
 295         (malyon-begin-section)
 296       (erase-buffer))))
 297
 298 (if (fboundp 'int-to-char)
 299     (defalias 'malyon-int-to-char 'int-to-char)
 300   (defun malyon-int-to-char (i)
 301     "Convert an integer into a character."
 302     i))
 303
 304 (if (fboundp 'mapc)
 305     (defalias 'malyon-mapc 'mapc)
 306   (defun malyon-mapc (function list)
 307     "Apply fun to every element of args ignoring the results."
 308     (if (null list)
 309         '()
 310       (funcall function (car list))
 311       (malyon-mapc function (cdr list)))))
 312
 313 (if (fboundp 'mapcan)
 314     (defalias 'malyon-mapcan 'mapcan)
 315   (defun malyon-mapcan (function list)
 316     "Apply fun to every element of args nconc'ing the result."
 317     (if (null list)
 318         '()
 319       (nconc (funcall function (car list))
 320              (malyon-mapcan function (cdr list))))))
 321
 322 ; Do not use the built-in conversion via 'multibyte-char-to-unibyte.
 323 (defun malyon-multibyte-char-to-unibyte (char)
 324   "Convert a multibyte character to unibyte."
 325   char)
 326
 327 (defun malyon-point-max (&optional buffer)
 328   "Get the point-max of the given buffer."
 329   (save-excursion
 330     (if buffer (set-buffer buffer))
 331     (point-max)))
 332
 333 (if (fboundp 'redisplay-frame)
 334     (defalias 'malyon-redisplay-frame 'redisplay-frame)
 335   (defun malyon-redisplay-frame (frame &rest ignore)
 336     "Redisplay the given frame."))
 337
 338 (if (fboundp 'remove)
 339     (defalias 'malyon-remove 'remove)
 340   (defun malyon-remove (element list)
 341     "Remove the element from the list."
 342     (cond ((null list)
 343            '())
 344           ((eq element (car list))
 345            (malyon-remove element (cdr list)))
 346           ((equal element (car list))
 347            (malyon-remove element (cdr list)))
 348           (t
 349            (cons (car list)
 350                  (malyon-remove element (cdr list)))))))
 351
 352 (if (fboundp 'set-keymap-name)
 353     (defalias 'malyon-set-keymap-name 'set-keymap-name)
 354   (defun malyon-set-keymap-name (keymap name)
 355     "Set the name of the keymap."))
 356
 357 (if (fboundp 'string-to-list)
 358     (defalias 'malyon-string-to-list 'string-to-list)
 359   (defun malyon-string-to-list (s)
 360     "Convert a string into a list of characters."
 361     (let ((i (- (length s) 1)) (l '()))
 362       (while (<= 0 i)
 363         (setq l (cons (aref s i) l)
 364               i (- i 1)))
 365       l)))
 366
 367 (if (fboundp 'string-to-vector)
 368     (defalias 'malyon-string-to-vector 'string-to-vector)
 369   (defun malyon-string-to-vector (s)
 370     "Convert a string into a vector of characters."
 371     (let* ((i 0) (l (length s)) (v (make-vector l 0)))
 372       (while (< i l)
 373         (aset v i (aref s i))
 374         (setq i (+ 1 i)))
 375       v)))
 376
 377 ; Do not use the built-in conversion via 'unibyte-char-to-multibyte.
 378 (defun malyon-unibyte-char-to-multibyte (char)
 379   "Convert a unibyte character to multibyte."
 380   char)
 381
 382 (defun malyon-vector-to-list (v begin end)
 383   "Return a list of elements in v in the range [begin, end)."
 384   (let ((result '()))
 385     (while (< begin end)
 386       (setq result (cons (aref v begin) result))
 387       (setq begin (+ 1 begin)))
 388     (reverse result)))
 389
 390 (if (fboundp 'window-displayed-height)
 391     (defalias 'malyon-window-displayed-height 'window-displayed-height)
 392   (defun malyon-window-displayed-height (&optional window)
 393     "Get the height of the window's displayed region."
 394     (- (window-height) 1)))
 395
 396 (if (fboundp 'yes-or-no-p-minibuf)
 397     (defalias 'malyon-yes-or-no-p-minibuf 'yes-or-no-p-minibuf)
 398   (defun malyon-yes-or-no-p-minibuf (prompt)
 399     "Ask a yes or no question."
 400     (yes-or-no-p prompt)))
 401
 402 ;; global variables for the malyon mode
 403
 404 (defvar malyon-syntax-table nil
 405   "Syntax table used while in malyon mode (same as in text-mode).")
 406
 407 (if malyon-syntax-table
 408     '()
 409   (setq malyon-syntax-table (make-syntax-table))
 410   (modify-syntax-entry ?\" ".   " malyon-syntax-table)
 411   (modify-syntax-entry ?\\ ".   " malyon-syntax-table)
 412   (modify-syntax-entry ?'  "w   " malyon-syntax-table))
 413
 414 (defvar malyon-keymap-read nil
 415   "Keymap for malyon mode for reading input into a buffer.")
 416
 417 (defvar malyon-history-saved-up nil
 418   "The saved binding for the up arrow key.")
 419
 420 (defvar malyon-history-saved-down nil
 421   "The saved binding for the down arrow key.")
 422
 423 (if malyon-keymap-read
 424     '()
 425   (setq malyon-keymap-read (make-sparse-keymap))
 426   (malyon-set-keymap-name malyon-keymap-read 'malyon-keymap-read)
 427   (setq malyon-history-saved-up   (global-key-binding [up]))
 428   (setq malyon-history-saved-down (global-key-binding [down]))
 429   (define-key malyon-keymap-read "\r"        'malyon-end-input)
 430   (define-key malyon-keymap-read [up]        'malyon-history-previous-char)
 431   (define-key malyon-keymap-read [down]      'malyon-history-next-char)
 432   (define-key malyon-keymap-read "\M-p"      'malyon-history-previous-char)
 433   (define-key malyon-keymap-read "\M-n"      'malyon-history-next-char)
 434   (define-key malyon-keymap-read "\C-a"      'malyon-beginning-of-line)
 435   (define-key malyon-keymap-read "\C-w"      'malyon-kill-region)
 436   (define-key malyon-keymap-read "\C-k"      'malyon-kill-line)
 437   (define-key malyon-keymap-read "\M-d"      'malyon-kill-word)
 438   (define-key malyon-keymap-read "\C-y"      'malyon-yank)
 439   (define-key malyon-keymap-read "\M-y"      'malyon-yank-pop)
 440   (define-key malyon-keymap-read "\C-d"      'malyon-delete-char)
 441   (define-key malyon-keymap-read "\d"        'malyon-backward-delete-char)
 442   (define-key malyon-keymap-read [del]       'malyon-delete-char)
 443   (define-key malyon-keymap-read [backspace] 'malyon-backward-delete-char)
 444   (substitute-key-definition (lookup-key (current-global-map) "a")
 445                              'malyon-self-insert-command
 446                              malyon-keymap-read (current-global-map)))
 447
 448 (defvar malyon-keymap-readchar nil
 449   "Keymap for malyon mode for waiting for input.")
 450
 451 (if malyon-keymap-readchar
 452     '()
 453   (setq malyon-keymap-readchar (make-sparse-keymap))
 454   (malyon-set-keymap-name malyon-keymap-readchar 'malyon-keymap-readchar)
 455   (define-key malyon-keymap-readchar "\r" 'malyon-wait-char)
 456   (substitute-key-definition (lookup-key (current-global-map) "a")
 457                              'malyon-wait-char
 458                              malyon-keymap-readchar (current-global-map)))
 459
 460 (defvar malyon-keymap-more nil
 461   "Keymap for malyon mode for browsing through text.")
 462
 463 (if malyon-keymap-more
 464     '()
 465   (setq malyon-keymap-more (make-sparse-keymap))
 466   (malyon-set-keymap-name malyon-keymap-more 'malyon-keymap-more)
 467   (define-key malyon-keymap-more "\r" 'malyon-more-char)
 468   (substitute-key-definition (lookup-key (current-global-map) "a")
 469                              'malyon-more-char
 470                              malyon-keymap-more (current-global-map)))
 471
 472 (defvar malyon-keymap-more-status nil
 473   "Keymap for malyon mode for browsing through the status buffer.")
 474
 475 (if malyon-keymap-more-status
 476     '()
 477   (setq malyon-keymap-more-status (make-sparse-keymap))
 478   (malyon-set-keymap-name malyon-keymap-more-status 'malyon-keymap-more-status)
 479   (define-key malyon-keymap-more-status "\r" 'malyon-more-char-status)
 480   (substitute-key-definition (lookup-key (current-global-map) "a")
 481                              'malyon-more-char-status
 482                              malyon-keymap-more-status (current-global-map)))
 483
 484 (defvar malyon-faces nil
 485   "An association list of text faces used by the malyon mode.")
 486
 487 (defun malyon-initialize-faces ()
 488   (copy-face 'default  'malyon-face-plain)
 489   (copy-face 'bold     'malyon-face-reverse)
 490   (copy-face 'bold     'malyon-face-bold)
 491   (copy-face 'italic   'malyon-face-italic)
 492   (copy-face 'default  'malyon-face-error)
 493   (set-face-foreground 'malyon-face-error "red")
 494   (setq malyon-faces '((0 . malyon-face-plain)
 495                        (1 . malyon-face-reverse)
 496                        (2 . malyon-face-bold)
 497                        (4 . malyon-face-italic)
 498                        (8 . malyon-face-plain))))
 499
 500 (defvar malyon-print-separator nil
 501   "A flag indicating whether to print the * * * separator.")
 502
 503 (defun malyon-begin-section ()
 504   "Print a section divider and begin a new section."
 505   (if malyon-print-separator
 506       (progn
 507         (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n ?* ?  ?* ?  ?*))
 508         (center-line)
 509         (malyon-mapc 'malyon-putchar-transcript '(?\n ?\n))
 510         (setq malyon-print-separator nil)))
 511   (narrow-to-region (point-max) (point-max)))
 512
 513 (if malyon-whitespace
 514     '()
 515   (setq malyon-whitespace (list (malyon-char-to-int ? )
 516                                 (malyon-char-to-int ?\t)
 517                                 (malyon-char-to-int ?\n)
 518                                 (malyon-char-to-int ?\r))))
 519
 520 ;; memory utilities
 521
 522 (defsubst malyon-read-byte (address)
 523   "Read a byte at address in the story file."
 524   (if (<= 0 address)
 525       (aref malyon-story-file address)
 526     (aref malyon-story-file (+ 65536 address))))
 527
 528 (defsubst malyon-store-byte (address value)
 529   "Store a byte at address in the story file."
 530   (if (<= 0 address)
 531       (aset malyon-story-file address (logand 255 value))
 532     (aset malyon-story-file (+ 65536 address) (logand 255 value))))
 533
 534 (defsubst malyon-read-word (address)
 535   "Read a word at address in the story file."
 536   (if (<= 0 address)
 537       (logior (lsh (aref malyon-story-file address) 8)
 538               (aref malyon-story-file (+ 1 address)))
 539     (logior (lsh (aref malyon-story-file (+ 65536 address)) 8)
 540             (aref malyon-story-file (+ 65537 address)))))
 541
 542 (defsubst malyon-store-word (address value)
 543   "Store a word at address in the story file."
 544   (if (<= 0 address)
 545       (progn
 546         (aset malyon-story-file address (logand 255 (lsh value -8)))
 547         (aset malyon-story-file (+ 1 address) (logand 255 value)))
 548     (aset malyon-story-file (+ 65536 address) (logand 255 (lsh value -8)))
 549     (aset malyon-story-file (+ 65537 address) (logand 255 value))))
 550
 551 (defsubst malyon-read-code-byte ()
 552   "Read the next byte at the program counter location."
 553   (setq malyon-instruction-pointer (+ malyon-instruction-pointer 1))
 554   (malyon-read-byte (- malyon-instruction-pointer 1)))
 555
 556 (defsubst malyon-read-code-word ()
 557   "Read the next word at the program counter location."
 558   (setq malyon-instruction-pointer (+ malyon-instruction-pointer 2))
 559   (malyon-read-word (- malyon-instruction-pointer 2)))
 560
 561 (defsubst malyon-pop-stack ()
 562   "Pop a value off the stack."
 563   (if (> 0 malyon-stack-pointer)
 564       (malyon-fatal-error "stack underflow."))
 565   (setq malyon-stack-pointer (- malyon-stack-pointer 1))
 566   (aref malyon-stack (+ malyon-stack-pointer 1)))
 567
 568 (defsubst malyon-read-local-variable (variable)
 569   "Read a local variable."
 570   (aref malyon-stack (+ variable malyon-frame-pointer)))
 571
 572 (defsubst malyon-read-global-variable (variable)
 573   "Read a global variable."
 574   (malyon-read-word (+ malyon-global-variables (* 2 variable))))
 575
 576 (defsubst malyon-read-variable (variable)
 577   "Read a variable."
 578   (cond ((= variable 0)  (malyon-pop-stack))
 579         ((< variable 16) (malyon-read-local-variable variable))
 580         (t               (malyon-read-global-variable (- variable 16)))))
 581
 582 (defsubst malyon-push-stack (value)
 583   "Push a value onto the stack."
 584   (setq malyon-stack-pointer (+ malyon-stack-pointer 1))
 585   (aset malyon-stack malyon-stack-pointer value))
 586
 587 (defsubst malyon-store-local-variable (variable value)
 588   "Store a value in a local variable."
 589   (aset malyon-stack (+ variable malyon-frame-pointer) value))
 590
 591 (defsubst malyon-store-global-variable (variable value)
 592   "Store a value in a global variable."
 593   (malyon-store-word (+ malyon-global-variables (* 2 variable)) value))
 594
 595 (defsubst malyon-store-variable (var value)
 596   "Store the value in a variable."
 597   (setq value (logand 65535 value))
 598   (cond ((= var 0)  (malyon-push-stack value))
 599         ((< var 16) (malyon-store-local-variable var value))
 600         (t          (malyon-store-global-variable (- var 16) value))))
 601
 602 ;; list of opcodes
 603
 604 (defvar malyon-opcodes
 605   [malyon-opcode-nop
 606    malyon-opcode-je              malyon-opcode-jl
 607    malyon-opcode-jg              malyon-opcode-dec-chk
 608    malyon-opcode-inc-chk         malyon-opcode-jin
 609    malyon-opcode-test            malyon-opcode-or
 610    malyon-opcode-and             malyon-opcode-test-attr
 611    malyon-opcode-set-attr        malyon-opcode-clear-attr
 612    malyon-opcode-store           malyon-opcode-insert-obj
 613    malyon-opcode-loadw           malyon-opcode-loadb
 614    malyon-opcode-get-prop        malyon-opcode-get-prop-addr
 615    malyon-opcode-get-next-prop   malyon-opcode-add
 616    malyon-opcode-sub             malyon-opcode-mul
 617    malyon-opcode-div             malyon-opcode-mod
 618    malyon-opcode-calls           malyon-opcode-calln
 619    malyon-opcode-set-color       malyon-opcode-throw
 620    malyon-opcode-nop             malyon-opcode-nop
 621    malyon-opcode-nop             malyon-opcode-nop
 622    malyon-opcode-je              malyon-opcode-jl
 623    malyon-opcode-jg              malyon-opcode-dec-chk
 624    malyon-opcode-inc-chk         malyon-opcode-jin
 625    malyon-opcode-test            malyon-opcode-or
 626    malyon-opcode-and             malyon-opcode-test-attr
 627    malyon-opcode-set-attr        malyon-opcode-clear-attr
 628    malyon-opcode-store           malyon-opcode-insert-obj
 629    malyon-opcode-loadw           malyon-opcode-loadb
 630    malyon-opcode-get-prop        malyon-opcode-get-prop-addr
 631    malyon-opcode-get-next-prop   malyon-opcode-add
 632    malyon-opcode-sub             malyon-opcode-mul
 633    malyon-opcode-div             malyon-opcode-mod
 634    malyon-opcode-calls           malyon-opcode-calln
 635    malyon-opcode-set-color       malyon-opcode-throw
 636    malyon-opcode-nop             malyon-opcode-nop
 637    malyon-opcode-nop             malyon-opcode-nop
 638    malyon-opcode-je              malyon-opcode-jl
 639    malyon-opcode-jg              malyon-opcode-dec-chk
 640    malyon-opcode-inc-chk         malyon-opcode-jin
 641    malyon-opcode-test            malyon-opcode-or
 642    malyon-opcode-and             malyon-opcode-test-attr
 643    malyon-opcode-set-attr        malyon-opcode-clear-attr
 644    malyon-opcode-store           malyon-opcode-insert-obj
 645    malyon-opcode-loadw           malyon-opcode-loadb
 646    malyon-opcode-get-prop        malyon-opcode-get-prop-addr
 647    malyon-opcode-get-next-prop   malyon-opcode-add
 648    malyon-opcode-sub             malyon-opcode-mul
 649    malyon-opcode-div             malyon-opcode-mod
 650    malyon-opcode-calls           malyon-opcode-calln
 651    malyon-opcode-set-color       malyon-opcode-throw
 652    malyon-opcode-nop             malyon-opcode-nop
 653    malyon-opcode-nop             malyon-opcode-nop
 654    malyon-opcode-je              malyon-opcode-jl
 655    malyon-opcode-jg              malyon-opcode-dec-chk
 656    malyon-opcode-inc-chk         malyon-opcode-jin
 657    malyon-opcode-test            malyon-opcode-or
 658    malyon-opcode-and             malyon-opcode-test-attr
 659    malyon-opcode-set-attr        malyon-opcode-clear-attr
 660    malyon-opcode-store           malyon-opcode-insert-obj
 661    malyon-opcode-loadw           malyon-opcode-loadb
 662    malyon-opcode-get-prop        malyon-opcode-get-prop-addr
 663    malyon-opcode-get-next-prop   malyon-opcode-add
 664    malyon-opcode-sub             malyon-opcode-mul
 665    malyon-opcode-div             malyon-opcode-mod
 666    malyon-opcode-calls           malyon-opcode-calln
 667    malyon-opcode-set-color       malyon-opcode-throw
 668    malyon-opcode-nop             malyon-opcode-nop
 669    malyon-opcode-nop             malyon-opcode-jz
 670    malyon-opcode-get-sibling     malyon-opcode-get-child
 671    malyon-opcode-get-parent      malyon-opcode-get-prop-len
 672    malyon-opcode-inc             malyon-opcode-dec
 673    malyon-opcode-print-addr      malyon-opcode-calls
 674    malyon-opcode-remove-obj      malyon-opcode-print-obj
 675    malyon-opcode-ret             malyon-opcode-jump
 676    malyon-opcode-print-paddr     malyon-opcode-load
 677    malyon-opcode-calln           malyon-opcode-jz
 678    malyon-opcode-get-sibling     malyon-opcode-get-child
 679    malyon-opcode-get-parent      malyon-opcode-get-prop-len
 680    malyon-opcode-inc             malyon-opcode-dec
 681    malyon-opcode-print-addr      malyon-opcode-calls
 682    malyon-opcode-remove-obj      malyon-opcode-print-obj
 683    malyon-opcode-ret             malyon-opcode-jump
 684    malyon-opcode-print-paddr     malyon-opcode-load
 685    malyon-opcode-calln           malyon-opcode-jz
 686    malyon-opcode-get-sibling     malyon-opcode-get-child
 687    malyon-opcode-get-parent      malyon-opcode-get-prop-len
 688    malyon-opcode-inc             malyon-opcode-dec
 689    malyon-opcode-print-addr      malyon-opcode-calls
 690    malyon-opcode-remove-obj      malyon-opcode-print-obj
 691    malyon-opcode-ret             malyon-opcode-jump
 692    malyon-opcode-print-paddr     malyon-opcode-load
 693    malyon-opcode-calln           malyon-opcode-rtrue
 694    malyon-opcode-rfalse          malyon-opcode-print
 695    malyon-opcode-print-ret       malyon-opcode-nop
 696    malyon-opcode-illegal         malyon-opcode-illegal
 697    malyon-opcode-restart         malyon-opcode-ret-popped
 698    malyon-opcode-catch           malyon-opcode-quit
 699    malyon-opcode-new-line        malyon-opcode-illegal
 700    malyon-opcode-verify          malyon-opcode-illegal
 701    malyon-opcode-piracy          malyon-opcode-nop
 702    malyon-opcode-je              malyon-opcode-jl
 703    malyon-opcode-jg              malyon-opcode-dec-chk
 704    malyon-opcode-inc-chk         malyon-opcode-jin
 705    malyon-opcode-test            malyon-opcode-or
 706    malyon-opcode-and             malyon-opcode-test-attr
 707    malyon-opcode-set-attr        malyon-opcode-clear-attr
 708    malyon-opcode-store           malyon-opcode-insert-obj
 709    malyon-opcode-loadw           malyon-opcode-loadb
 710    malyon-opcode-get-prop        malyon-opcode-get-prop-addr
 711    malyon-opcode-get-next-prop   malyon-opcode-add
 712    malyon-opcode-sub             malyon-opcode-mul
 713    malyon-opcode-div             malyon-opcode-mod
 714    malyon-opcode-calls           malyon-opcode-calln
 715    malyon-opcode-set-color       malyon-opcode-throw
 716    malyon-opcode-nop             malyon-opcode-nop
 717    malyon-opcode-nop             malyon-opcode-calls
 718    malyon-opcode-storew          malyon-opcode-storeb
 719    malyon-opcode-put-prop        malyon-opcode-aread
 720    malyon-opcode-print-char      malyon-opcode-print-num
 721    malyon-opcode-random          malyon-opcode-push
 722    malyon-opcode-pull            malyon-opcode-split-window
 723    malyon-opcode-set-window      malyon-opcode-calls
 724    malyon-opcode-erase-window    malyon-opcode-erase-line
 725    malyon-opcode-set-cursor      malyon-opcode-get-cursor
 726    malyon-opcode-set-text-style  malyon-opcode-buffer-mode
 727    malyon-opcode-output-stream   malyon-opcode-input-stream
 728    malyon-opcode-nop             malyon-opcode-read-char
 729    malyon-opcode-scan-table      malyon-opcode-not
 730    malyon-opcode-calln           malyon-opcode-calln
 731    malyon-opcode-tokenise        malyon-opcode-encode-text
 732    malyon-opcode-copy-table      malyon-opcode-print-table
 733    malyon-opcode-check-arg-count malyon-opcode-save
 734    malyon-opcode-restore         malyon-opcode-log-shift
 735    malyon-opcode-art-shift       malyon-opcode-set-font
 736    malyon-opcode-illegal         malyon-opcode-illegal
 737    malyon-opcode-illegal         malyon-opcode-illegal
 738    malyon-opcode-save-undo       malyon-opcode-restore-undo
 739    malyon-opcode-print-unicode   malyon-opcode-check-unicode
 740    malyon-opcode-nop             malyon-opcode-nop
 741    malyon-opcode-nop]
 742   "A vector of all known legal z code opcodes.")
 743
 744 ;; initialization
 745
 746 (defun malyon-load-story-file (file-name)
 747   "Load a z code story file into an internal vector."
 748   (save-excursion
 749     (set-buffer (create-file-buffer file-name))
 750     (malyon-disable-multibyte)
 751     (malyon-erase-buffer)
 752     (let ((coding-system-for-read 'binary))
 753       (insert-file-contents file-name))
 754     (setq malyon-story-file-name file-name)
 755     (setq malyon-story-file (buffer-substring-no-properties (point-min)
 756                                                             (point-max)))
 757     (setq malyon-story-file (malyon-string-to-vector malyon-story-file))
 758     (if (not (eq ?\^A 1))
 759         (let ((i 0))
 760           (while (< i (length malyon-story-file))
 761             (aset malyon-story-file
 762                   i
 763                   (malyon-char-to-int (aref malyon-story-file i)))
 764             (setq i (+ 1 i)))))
 765     (kill-buffer nil)))
 766
 767 (defun malyon-initialize ()
 768   "Initialize the z code interpreter."
 769 ;  (malyon-trace-file)
 770   (setq malyon-game-state-quetzal t)
 771   (malyon-initialize-faces)
 772   (malyon-initialize-status)
 773   (malyon-initialize-transcript)
 774   (malyon-initialize-windows)
 775   (malyon-initialize-story-header)
 776   (malyon-initialize-registers)
 777   (malyon-initialize-opcodes)
 778   (malyon-history-clear)
 779   (setq malyon-game-state-restart (malyon-current-game-state))
 780   (malyon-print-header))
 781
 782 (defun malyon-initialize-status ()
 783   "Initialize the status buffer."
 784   (setq malyon-status-buffer (get-buffer-create "Malyon Status"))
 785   (switch-to-buffer malyon-status-buffer)
 786   (malyon-erase-buffer)
 787   (kill-all-local-variables)
 788   (setq malyon-status-buffer-point (point))
 789   (setq malyon-status-buffer-lines 0)
 790   (setq malyon-status-buffer-delayed-split nil)
 791   (use-local-map malyon-keymap-read)
 792   (set-syntax-table malyon-syntax-table)
 793   (setq mode-name "Malyon")
 794   (setq major-mode 'malyon-mode)
 795   (run-hooks 'malyon-mode-hook))
 796
 797 (defun malyon-initialize-transcript ()
 798   "Initialize the transcript buffer."
 799   (setq malyon-transcript-buffer (get-buffer-create "Malyon Transcript"))
 800   (switch-to-buffer malyon-transcript-buffer)
 801   (malyon-erase-buffer)
 802   (kill-all-local-variables)
 803   (setq malyon-last-cursor-position-after-input
 804         (malyon-point-max malyon-transcript-buffer))
 805   (use-local-map malyon-keymap-read)
 806   (set-syntax-table malyon-syntax-table)
 807   (setq fill-column malyon-max-column)
 808   (auto-fill-mode 1)
 809   (setq mode-name "Malyon")
 810   (setq major-mode 'malyon-mode)
 811   (run-hooks 'malyon-mode-hook))
 812
 813 (defun malyon-initialize-windows ()
 814   "Initialize the window configuration for the z machine."
 815   (setq window-min-height 3)
 816   (setq malyon-transcript-buffer-buffered t)
 817   (malyon-set-window-configuration 0)
 818   (malyon-opcode-set-window 0))
 819
 820 (defun malyon-initialize-story-header ()
 821   "Initializes the header section of the story file."
 822   (malyon-store-byte 1
 823                      (if (>= malyon-story-version 5)
 824                          28
 825                        (logior 48 (malyon-read-byte 1))))
 826   (malyon-store-byte 16 (logand 440 (malyon-read-byte 16)))
 827   (malyon-store-byte 30 1)
 828   (malyon-store-byte 31 65)
 829   (malyon-store-byte 32 255)
 830   (malyon-store-byte 33 (- malyon-max-column 1))
 831   (malyon-store-word 34 (- malyon-max-column 1))
 832   (malyon-store-word 36 255)
 833   (malyon-store-word 38 1)
 834   (malyon-store-word 39 1)
 835   (malyon-store-byte 44 0)
 836   (malyon-store-byte 45 0)
 837   (malyon-store-byte 50 1)
 838   (malyon-store-byte 51 0))
 839
 840 (defun malyon-initialize-registers ()
 841   "Initialize the interpreter's internal registers."
 842   (setq malyon-stack (make-vector 1024 0))
 843   (setq malyon-stack-pointer -1)
 844   (malyon-push-initial-frame)
 845   (setq malyon-frame-pointer malyon-stack-pointer)
 846   (setq malyon-instruction-pointer (malyon-read-word 6))
 847   (setq malyon-global-variables (malyon-read-word 12))
 848   (setq malyon-object-table (malyon-read-word 10))
 849   (cond ((< malyon-story-version 5)
 850          (setq malyon-object-table-entry-size 9)
 851          (setq malyon-object-properties       31)
 852          (setq malyon-object-property-offset  7))
 853         (t
 854          (setq malyon-object-table-entry-size 14)
 855          (setq malyon-object-properties       63)
 856          (setq malyon-object-property-offset  12)))
 857   (setq malyon-abbreviations (malyon-read-word 24))
 858   (if (< malyon-story-version 5)
 859       (setq malyon-score-game (zerop (logand 2 (malyon-read-byte 1)))))
 860   (setq malyon-packed-multiplier
 861         (malyon-cadr (assq malyon-story-version '((3 2) (5 4) (8 8)))))
 862   (if (or (< malyon-story-version 5) (zerop (malyon-read-word 52)))
 863       (setq malyon-alphabet (concat "abcdefghijklmnopqrstuvwxyz"
 864                                     "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 865                                     " \n0123456789.,!?_#'\"/\\-:()"))
 866     (setq malyon-alphabet (make-string 78 ? ))
 867     (let ((i 0))
 868       (while (< i 78)
 869         (aset malyon-alphabet i
 870               (malyon-read-byte (+ i (malyon-read-word 52))))
 871         (setq i (+ 1 i)))))
 872   (malyon-initialize-unicode-table)
 873   (setq malyon-dictionary (malyon-read-word 8))
 874   (setq malyon-dictionary-entry-length
 875         (malyon-read-byte
 876          (+ 1 malyon-dictionary (malyon-read-byte malyon-dictionary))))
 877   (setq malyon-dictionary-num-entries
 878         (malyon-read-word
 879          (+ 2 malyon-dictionary (malyon-read-byte malyon-dictionary))))
 880   (setq malyon-dictionary-entries
 881         (+ 4 malyon-dictionary (malyon-read-byte malyon-dictionary)))
 882   (setq malyon-dictionary-word-length (if (< malyon-story-version 5) 3 5))
 883   (setq malyon-current-face 'malyon-face-plain)
 884   (setq malyon-print-separator nil)
 885   (malyon-initialize-output-streams))
 886
 887 (defun malyon-initialize-opcodes ()
 888   "Initialize the opcode table used by the story file."
 889   (cond ((< malyon-story-version 5)
 890          (aset malyon-opcodes 143 'malyon-opcode-not)
 891          (aset malyon-opcodes 181 'malyon-opcode-save)
 892          (aset malyon-opcodes 182 'malyon-opcode-restore)
 893          (aset malyon-opcodes 185 'malyon-opcode-pop)
 894          (aset malyon-opcodes 188 'malyon-opcode-show-status))
 895         (t
 896          (aset malyon-opcodes 143 'malyon-opcode-calln)
 897          (aset malyon-opcodes 181 'malyon-opcode-illegal)
 898          (aset malyon-opcodes 182 'malyon-opcode-illegal)
 899          (aset malyon-opcodes 185 'malyon-opcode-catch)
 900          (aset malyon-opcodes 188 'malyon-opcode-illegal))))
 901
 902 (defun malyon-print-header ()
 903   "Print malyon mode header information."
 904   (malyon-opcode-set-text-style 2)
 905   (malyon-print "Malyon V 1.0.2")
 906   (malyon-opcode-set-text-style 0)
 907   (malyon-newline)
 908   (malyon-print "A z-code interpreter for version 3, 5, and 8 games.")
 909   (malyon-newline)
 910   (malyon-print "(c) 1999-2009 by Peter Ilberg <peter.ilberg@gmail.com>")
 911   (malyon-newline)
 912   (malyon-newline))
 913
 914 ;; cleanup
 915
 916 (defun malyon-cleanup ()
 917   "Clean up the z code interpreter."
 918   (condition-case nil
 919       (progn
 920         (setq malyon-story-file nil)
 921         (setq malyon-window-configuration nil)
 922         (setq malyon-game-state-restart nil)
 923         (setq malyon-game-state-undo nil)
 924         (if (get-buffer "Malyon Status")
 925             (kill-buffer (get-buffer "Malyon Status")))
 926         (if (get-buffer "Malyon Transcript")
 927             (progn
 928               (switch-to-buffer (get-buffer "Malyon Transcript"))
 929               (malyon-redisplay-frame (selected-frame) t)
 930               (delete-other-windows (get-buffer-window (current-buffer)))
 931               (widen)
 932               (text-mode)))
 933         (setq malyon-status-buffer nil)
 934         (setq malyon-transcript-buffer nil))
 935     (error
 936      (malyon-fatal-error "cleanup failed."))))
 937
 938 ;; error handling
 939
 940 (defun malyon-fatal-error (message)
 941   "Print error message and abort."
 942   (setq message (concat "Malyon fatal error: " message))
 943   (unwind-protect
 944       (save-excursion
 945         (set-buffer malyon-transcript-buffer)
 946         (goto-char (point-max))
 947         (newline)
 948         (newline)
 949         (put-text-property 0
 950                            (length message)
 951                            'face
 952                            'malyon-face-error
 953                            message)
 954         (insert message)
 955         (newline))
 956     (malyon-cleanup)
 957     (malyon-redisplay-frame (selected-frame) t)
 958     (error message)))
 959
 960 ;; conversion of zscii to ascii
 961
 962 (defvar malyon-unicode-table nil
 963   "An array mapping zscii characters to latin-1 ones.")
 964
 965 (defvar malyon-default-unicode-table nil
 966   "The default array mapping zscii characters to latin-1 ones.")
 967
 968 (if malyon-default-unicode-table
 969     '()
 970   (setq malyon-default-unicode-table
 971         [32
 972          0   0   0   0   0   0   0       ;   1 -   7
 973          8   0   0   0   0   10  0   0   ;   8 -  15
 974          0   0   0   0   0   0   0   0   ;  16 -  23
 975          0   0   0   39  0   0   0   0   ;  24 -  31
 976          32  33  34  35  36  37  38  39  ;  32 -  39
 977          40  41  42  43  44  45  46  47  ;  40 -  47
 978          48  49  50  51  52  53  54  55  ;  48 -  55
 979          56  57  58  59  60  61  62  63  ;  56 -  63
 980          64  65  66  67  68  69  70  71  ;  64 -  71
 981          72  73  74  75  76  77  78  79  ;  72 -  79
 982          80  81  82  83  84  85  86  87  ;  80 -  87
 983          88  89  90  91  92  93  94  95  ;  88 -  95
 984          96  97  98  99  100 101 102 103 ;  96 - 103
 985          104 105 106 107 108 109 110 111 ; 104 - 111
 986          112 113 114 115 116 117 118 119 ; 112 - 119
 987          120 121 122 123 124 125 126 0   ; 120 - 127
 988          0   0   0   0   0   0   0   0   ; 128 - 135
 989          0   0   0   0   0   0   0   0   ; 136 - 143
 990          0   48  49  50  51  52  53  54  ; 144 - 151
 991          55  56  57  228 246 252 196 214 ; 152 - 159
 992          220 223 187 171 235 239 255 203 ; 160 - 167
 993          207 225 233 237 243 250 253 193 ; 168 - 175
 994          201 205 211 218 221 224 232 236 ; 176 - 183
 995          242 249 192 200 204 210 217 226 ; 184 - 191
 996          234 238 244 251 194 202 206 212 ; 192 - 199
 997          219 229 197 248 216 227 241 245 ; 200 - 207
 998          195 209 213 230 198 231 199 254 ; 208 - 215
 999          240 222 208 163 63  63  161 191 ; 216 - 223
1000          0   0   0   0   0   0   0   0   ; 224 - 231
1001          0   0   0   0   0   0   0   0   ; 232 - 239
1002          0   0   0   0   0   0   0   0   ; 240 - 247
1003          0   0   0   0   0   0   0   0   ; 248 - 255
1004          ]))
1005
1006 (defun malyon-initialize-unicode-table ()
1007   "Initializes the zscii-to-unicode conversion table."
1008   (setq malyon-unicode-table
1009         (copy-sequence malyon-default-unicode-table))
1010   (let* ((ext   (malyon-read-word 54))
1011          (len   (if (zerop ext) 0 (malyon-read-word ext)))
1012          (table (if (< len 3)   0 (malyon-read-word (+ ext 6)))))
1013     (if (or (< malyon-story-version 5) (zerop table))
1014         '()
1015       (let ((i 0))
1016         (while (< i 96)
1017           (aset malyon-unicode-table (+ 155 i) (malyon-char-to-int ??))
1018           (setq i (+ 1 i))))
1019       (setq len (malyon-read-byte table))
1020       (let ((i 0))
1021         (while (< i len)
1022           (aset malyon-unicode-table (+ 155 i)
1023                 (malyon-read-word (+ table 1 i)))
1024           (setq i (+ 1 i)))))))
1025
1026 (defsubst malyon-zscii-to-unicode (char)
1027   "Converts a zscii character to unicode."
1028   (if (or (< char 0) (> char 255))
1029       ??
1030     (let ((uni (aref malyon-unicode-table char)))
1031       (if (zerop uni)
1032           ??
1033         (malyon-unibyte-char-to-multibyte (malyon-int-to-char uni))))))
1034
1035 (defsubst malyon-unicode-to-zscii (char)
1036   "Converts a unicode character to zscii."
1037   (setq char (malyon-multibyte-char-to-unibyte char))
1038   (setq char (if (malyon-characterp char) (malyon-char-to-int char) char))
1039   (if (= 13 char)
1040       ?\r
1041     (let ((i 1) (found 0))
1042       (while (and (< i 255) (zerop found))
1043         (if (= char (aref malyon-unicode-table i))
1044             (setq found i))
1045         (setq i (+ i 1)))
1046       (malyon-int-to-char found))))
1047
1048 ;; output streams
1049
1050 (defvar malyon-output-streams nil
1051   "Valid output streams for the interpreter.")
1052
1053 (defvar malyon-output-streams-tables nil
1054   "A list of active tables for stream 3.")
1055
1056 (defun malyon-initialize-output-streams ()
1057   "Initializes the output streams."
1058   (setq malyon-output-streams '())
1059   (setq malyon-output-streams-tables '())
1060   (malyon-add-output-stream 1 0))
1061
1062 (defun malyon-output-stream-function (stream)
1063   "Returns the output function representing the given stream."
1064   (cond ((= 1 stream) (if (zerop malyon-current-window)
1065                           'malyon-putchar-transcript
1066                         'malyon-putchar-status))
1067         ((= 2 stream) 'malyon-putchar-printer)))
1068
1069 (defun malyon-add-output-stream (stream table)
1070   "Add a new output stream."
1071   (if (= stream 3)
1072       (progn
1073         (setq malyon-output-streams-tables
1074               (cons table malyon-output-streams-tables))
1075         (malyon-store-word table 0))
1076     (let ((function (malyon-output-stream-function stream)))
1077       (setq malyon-output-streams
1078             (if (member function malyon-output-streams)
1079                 malyon-output-streams
1080               (cons function malyon-output-streams))))))
1081
1082 (defun malyon-remove-output-stream (stream)
1083   "Remove an output stream."
1084   (if (= stream 3)
1085       (setq malyon-output-streams-tables (cdr malyon-output-streams-tables))
1086     (setq malyon-output-streams
1087           (malyon-remove (malyon-output-stream-function stream)
1088                          malyon-output-streams))))
1089
1090 (defun malyon-update-output-streams ()
1091   "Update output streams when the output window has changed."
1092   (let ((one (or (member 'malyon-putchar-transcript malyon-output-streams)
1093                  (member 'malyon-putchar-status     malyon-output-streams))))
1094     (setq malyon-output-streams
1095           (malyon-remove 'malyon-putchar-transcript
1096                          (malyon-remove 'malyon-putchar-status
1097                                         malyon-output-streams)))
1098     (if one
1099         (malyon-add-output-stream 1 0))))
1100
1101 (defsubst malyon-output-character (char)
1102   "Output a single character on all active streams."
1103   (setq char (malyon-zscii-to-unicode char))
1104   (if malyon-output-streams-tables
1105       (malyon-putchar-table char (car malyon-output-streams-tables))
1106     (malyon-mapc (lambda (s) (funcall s char)) malyon-output-streams)))
1107
1108 ;; printing text
1109
1110 (defsubst malyon-abbrev (abbrev x)
1111   "Print an abbreviation."
1112   (malyon-print-ztext
1113    (* 2 (malyon-read-word (+ malyon-abbreviations
1114                              (* 2 (+ x (* 32 (1- abbrev)))))))))
1115
1116 (defun malyon-newline ()
1117   "Print a newline."
1118   (if (eq malyon-status-buffer (current-buffer))
1119       (goto-char malyon-status-buffer-point)
1120     (goto-char (point-max)))
1121   (malyon-output-character ?\r)
1122   (if (eq malyon-status-buffer (current-buffer))
1123       (setq malyon-status-buffer-point (point))
1124     (goto-char malyon-last-cursor-position-after-input))
1125   (malyon-redisplay-frame (selected-frame) nil))
1126
1127 (defun malyon-print (object)
1128   "Print text."
1129   (let ((text (if (malyon-characterp object) (char-to-string object) object))
1130         (start))
1131     (if (eq malyon-transcript-buffer (current-buffer))
1132         (goto-char (point-max))
1133       (goto-char malyon-status-buffer-point))
1134     (setq start (point))
1135     (malyon-print-characters (malyon-string-to-list text))
1136     (put-text-property start (point) 'face malyon-current-face)
1137     (if (eq malyon-status-buffer (current-buffer))
1138         (setq malyon-status-buffer-point (point))
1139       (goto-char malyon-last-cursor-position-after-input))))
1140
1141 (defun malyon-print-characters (text)
1142   "Print a list of characters."
1143   (malyon-mapc 'malyon-output-character text))
1144
1145 (defsubst malyon-print-state-new (char shift abbr zscii zcode)
1146   "Generate a new print state."
1147   (list char shift abbr zscii zcode))
1148
1149 (defsubst malyon-print-state-initial ()
1150   "Returns an initial state for the ztext decoder."
1151   (malyon-print-state-new nil -6 0 0 0))
1152
1153 (defsubst malyon-print-state-next (x ignore shift abbr zscii z)
1154   "Print state transition function."
1155   (cond ((= zscii 2)
1156          (malyon-print-state-new (+ z x) -6 0 0 0))
1157         ((= zscii 1)
1158          (malyon-print-state-new nil     -6 0 2 (* 32 x)))
1159         ((> abbr 0)
1160          (malyon-abbrev abbr x)
1161          (malyon-print-state-initial))
1162         ((= x 0)
1163          (malyon-print-state-new ?       -6 0 0 0))
1164         ((< x 4)
1165          (malyon-print-state-new nil     -6 x 0 0))
1166         ((= x 4)
1167          (malyon-print-state-new nil     20 0 0 0))
1168         ((= x 5)
1169          (malyon-print-state-new nil     46 0 0 0))
1170         ((and (= shift 46) (= x 6))
1171          (malyon-print-state-new nil     -6 0 1 0))
1172         ((and (= shift 46) (= x 7))
1173          (malyon-print-state-new ?\r     -6 0 0 0))
1174         (t
1175          (malyon-print-state-new
1176           (aref malyon-alphabet (+ shift x)) -6 0 0 0))))
1177
1178 (defun malyon-print-text (address)
1179   "Print text at address and return the address of the following byte."
1180   (let ((start))
1181     (if (eq malyon-transcript-buffer (current-buffer))
1182         (goto-char (point-max))
1183       (goto-char malyon-status-buffer-point))
1184     (setq start (point))
1185     (setq address (malyon-print-ztext address))
1186     (put-text-property start (point) 'face malyon-current-face)
1187     (if (eq malyon-status-buffer (current-buffer))
1188         (setq malyon-status-buffer-point (point))
1189       (goto-char malyon-last-cursor-position-after-input))
1190     (malyon-redisplay-frame (selected-frame) nil)
1191     address))
1192
1193 (defun malyon-print-ztext (address)
1194   "Print the ztext stored at the given address."
1195   (let ((high 0) (low) (a) (b) (c) (state (malyon-print-state-initial)))
1196     (while (zerop (logand 128 high))
1197       (setq high (malyon-read-byte address))
1198       (setq low  (malyon-read-byte (+ 1 address)))
1199       (setq a    (logand 31 (lsh high -2)))
1200       (setq b    (logand 31 (logior (lsh high 3) (lsh low -5))))
1201       (setq c    (logand 31 low))
1202       (setq state (apply 'malyon-print-state-next a state))
1203       (if (car state) (malyon-output-character (car state)))
1204       (setq state (apply 'malyon-print-state-next b state))
1205       (if (car state) (malyon-output-character (car state)))
1206       (setq state (apply 'malyon-print-state-next c state))
1207       (if (car state) (malyon-output-character (car state)))
1208       (setq address (+ 2 address)))
1209     address))
1210
1211 (defun malyon-putchar-transcript (char)
1212   "Print a single character in the transcript window."
1213   (if (char-equal char ?\n)
1214       (newline 1)
1215     (insert char)
1216     (setq malyon-print-separator (null (member char malyon-whitespace))))
1217   (if (and malyon-transcript-buffer-buffered
1218            (> (current-column) (current-fill-column)))
1219       (progn
1220         (end-of-line)
1221         (forward-word -1)
1222         (if (< 0 (current-column))
1223             (newline 1))
1224         (end-of-line))))
1225
1226 (defun malyon-putchar-status (char)
1227   "Print a single character in the status window."
1228   (if malyon-status-buffer-delayed-split
1229       (progn
1230         (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
1231         (other-window 1)))
1232   (if (char-equal char ?\n)
1233       (progn
1234         (beginning-of-line)
1235         (forward-line 1)
1236         (if (= (point) (point-max))
1237             (forward-line -1)))
1238     (if (> (current-column) (current-fill-column))
1239         '()
1240       (insert char)
1241       (delete-char 1))))
1242
1243 (defun malyon-putchar-table (char table)
1244   "Print a single character into a table."
1245   (setq char (malyon-unicode-to-zscii char))
1246   (malyon-store-byte (+ 2 table (malyon-read-word table)) char)
1247   (malyon-store-word table (+ 1 (malyon-read-word table))))
1248
1249 (defun malyon-putchar-printer (char)
1250   "Print a single character onto a printer."); not yet implemented
1251
1252 ;; more
1253
1254 (defvar malyon-more-continue-keymap nil
1255   "The keymap with which to continue after More has finished.")
1256
1257 (defun malyon-more (keymap)
1258   "Enter More mode."
1259   (if (eq malyon-status-buffer (current-buffer))
1260       (use-local-map keymap)
1261     (if (< malyon-story-version 5) (malyon-opcode-show-status))
1262     (if (< (count-lines malyon-last-cursor-position-after-input (point-max))
1263            (malyon-window-displayed-height))
1264         (progn
1265           (malyon-adjust-transcript)
1266           (use-local-map keymap))
1267       (goto-char malyon-last-cursor-position-after-input)
1268       (beginning-of-line)
1269       (recenter 1)
1270       (setq malyon-more-continue-keymap keymap)
1271       (use-local-map malyon-keymap-more)
1272       (message "[More]"))))
1273
1274 (defun malyon-more-status-buffer ()
1275   "Enter More mode for the status buffer."
1276   (setq malyon-more-continue-keymap (current-local-map))
1277   (use-local-map malyon-keymap-more-status)
1278   (message "[More]")
1279   (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
1280
1281 ;; input history
1282
1283 (defvar malyon-history nil
1284   "The input history.")
1285
1286 (defun malyon-history-previous ()
1287   "Move one entry up in the input history."
1288   (let ((prev (aref malyon-history 0))
1289         (curr (aref malyon-history 1))
1290         (next (aref malyon-history 2)))
1291     (if (null prev)
1292         curr
1293       (aset malyon-history 2 (if curr (cons curr next) next))
1294       (aset malyon-history 0 (cdr prev))
1295       (aset malyon-history 1 (car prev)))))
1296
1297 (defun malyon-history-next ()
1298   "Move one entry down in the input history."
1299   (let ((prev (aref malyon-history 0))
1300         (curr (aref malyon-history 1))
1301         (next (aref malyon-history 2)))
1302     (if (null next)
1303         curr
1304       (aset malyon-history 0 (if curr (cons curr prev) prev))
1305       (aset malyon-history 2 (cdr next))
1306       (aset malyon-history 1 (car next)))))
1307
1308 (defun malyon-history-clear ()
1309   "Clear the input history."
1310   (setq malyon-history (vector '() nil '())))
1311
1312 (defun malyon-history-insert (entry)
1313   "Insert an entry into the input history."
1314   (let* ((prev (aref malyon-history 0))
1315          (curr (aref malyon-history 1))
1316          (next (aref malyon-history 2))
1317          (l    (malyon-remove entry
1318                               (append (nreverse prev)
1319                                       (if curr (cons curr next) next))))
1320          (cut  (- (length l) 19)))
1321     (while (> cut 0)
1322       (setq l   (cdr l)
1323             cut (- cut 1)))
1324     (aset malyon-history 0
1325           (malyon-remove nil (malyon-remove "" (cons entry (nreverse l)))))
1326     (aset malyon-history 1 nil)
1327     (aset malyon-history 2 '())))
1328
1329 ;; dictionary lookup
1330
1331 (defun malyon-dictionary-word (chars)
1332   "Convert a list of characters into a dictionary word."
1333   (list (car (car chars))
1334         (length chars)
1335         (malyon-encode-dictionary-word (append (malyon-mapcan 'cdr chars)
1336                                                '(5 5 5 5 5 5 5 5)))))
1337
1338 (defsubst malyon-join-characters (stop list)
1339   "Joins three ztext characters into two bytes."
1340   (let ((a (car          list))
1341         (b (malyon-cadr  list))
1342         (c (malyon-caddr list))
1343         (x (if (zerop stop) 0 128)))
1344     (list (logior x (logand 255 (logior (lsh a 2) (lsh b -3))))
1345           (logand 255 (logior (lsh b 5) c)))))
1346
1347 (defun malyon-encode-dictionary-word (l)
1348   "Converts a list of ztext characters into a dictionary word."
1349   (let* ((first  l)
1350          (second (malyon-cdddr first))
1351          (third  (malyon-cdddr second)))
1352     (apply 'vector
1353            (if (< malyon-story-version 5)
1354                (append (malyon-join-characters 0 first)
1355                        (malyon-join-characters 1 second))
1356              (append (malyon-join-characters 0 first)
1357                      (malyon-join-characters 0 second)
1358                      (malyon-join-characters 1 third))))))
1359
1360 (defun malyon-lookup (dict code)
1361   "Look for the given code in the dictionary and return its address."
1362   (cond ((not code)                 0)
1363         ((not dict)                 (malyon-binary-search code))
1364         ((= dict malyon-dictionary) (malyon-binary-search code))
1365         (t                          (malyon-linear-search dict code))))
1366
1367 (defsubst malyon-compare-words (word address)
1368   "Compares the given word to the word stored at address."
1369   (let* ((i 0)
1370          (j address)
1371          (x (aref word i))
1372          (y (malyon-read-byte j)))
1373     (while (not (or (/= x y) (= i malyon-dictionary-word-length)))
1374       (setq i (+ 1 i)
1375             j (+ 1 j)
1376             x (aref word i)
1377             y (malyon-read-byte j)))
1378     (- x y)))
1379
1380 ;; search functions
1381
1382 (defun malyon-binary-search (code)
1383   "Binary search through the main dictionary."
1384   (let* ((lower   0)
1385          (upper   (- malyon-dictionary-num-entries 1))
1386          (median  (/ (+ lower upper) 2))
1387          (entry   (+ malyon-dictionary-entries
1388                      (* malyon-dictionary-entry-length median)))
1389          (looking (malyon-compare-words code entry)))
1390     (while (not (or (> lower upper) (zerop looking)))
1391       (setq lower   (if (< 0 looking) (+ median 1) lower)
1392             upper   (if (> 0 looking) (- median 1) upper)
1393             median  (/ (+ lower upper) 2)
1394             entry   (+ malyon-dictionary-entries
1395                        (* malyon-dictionary-entry-length median))
1396             looking (malyon-compare-words code entry)))
1397     (if (zerop looking) entry 0)))
1398
1399 (defun malyon-linear-search (dictionary code)
1400   "Linear search through the given dictionary."
1401   (let* ((length  (malyon-read-byte (+ dictionary 1
1402                                        (malyon-read-byte dictionary))))
1403          (number  (malyon-read-word (+ dictionary 2
1404                                        (malyon-read-byte dictionary))))
1405          (entries (+ dictionary 4 (malyon-read-byte dictionary)))
1406          (i       0)
1407          (entry   (+ entries (* length i)))
1408          (looking (malyon-compare-words code entry)))
1409     (while (not (or (>= i number) (zerop looking)))
1410       (setq i       (+ 1 i)
1411             entry   (+ entries (* length i))
1412             looking (malyon-compare-words code entry)))
1413     (if (zerop looking) entry 0)))
1414
1415 ;; encoding text and lexical analysis
1416
1417 (defun malyon-split-list (sep list &optional x)
1418   "Split a list into sublists as indicated by the separators."
1419   (cond ((null list)
1420          (list (nreverse x)))
1421         ((eq sep (car list))
1422          (cons (nreverse x) (malyon-split-list sep (cdr list) '())))
1423         (t
1424          (malyon-split-list sep (cdr list) (cons (car list) x)))))
1425
1426 (defun malyon-characters-to-words (list)
1427   "Turn the list of characters into a list of words."
1428   (mapcar 'malyon-dictionary-word
1429           (delete '() (malyon-split-list 'malyon-word-separator list))))
1430
1431 (defsubst malyon-char-in-string (c s)
1432   "Returns the index of c in s if found, or length of s."
1433   (let ((i 0))
1434     (while (not (or (= i (length s)) (= c (aref s i))))
1435       (setq i (+ 1 i)))
1436     i))
1437
1438 (defsubst malyon-encode-into-ztext (c)
1439   "Convert a character into ztext."
1440   (let* ((index (malyon-char-in-string c malyon-alphabet))
1441          (shift (floor index 26))
1442          (char  (+ 6 (mod index 26))))
1443     (cond ((> shift 2) (list 5 6 (logand 31 (lsh c -5)) (logand 31 c)))
1444           ((= shift 2) (list 5 char))
1445           ((= shift 1) (list 4 char))
1446           (t           (list char)))))
1447
1448 (defun malyon-encode-single-character (terminating-characters char)
1449   "Encode a character into ztext."
1450   (let ((pos (car char))
1451         (c   (cdr char)))
1452     (cond ((member c malyon-whitespace)
1453            (list 'malyon-word-separator))
1454           ((member c terminating-characters)
1455            (list 'malyon-word-separator
1456                  (cons pos (malyon-encode-into-ztext c))
1457                  'malyon-word-separator))
1458           (t (list (cons pos (malyon-encode-into-ztext c)))))))
1459
1460 (defun malyon-encode-character-list (dict list)
1461   "Encode the list of characters into ztext."
1462   (let ((l '())
1463         (i 0))
1464     (while (< i (malyon-read-byte dict))
1465       (setq l (cons (malyon-read-byte (+ dict 1 i)) l)
1466             i (+ 1 i)))
1467     (malyon-mapcan (lambda (x) (malyon-encode-single-character l x)) list)))
1468
1469 (defun malyon-text-length (address)
1470   "Return the length of the input text."
1471   (if (>= malyon-story-version 5)
1472       (malyon-read-byte (+ 1 address))
1473     (let ((i 0))
1474       (while (not (zerop (malyon-read-byte (+ i 1 address))))
1475         (setq i (+ i 1)))
1476       i)))
1477
1478 (defun malyon-text-to-character-list (address)
1479   "Convert the input text into a list of characters."
1480   (let ((i    (malyon-text-length address))
1481         (text '()))
1482     (while (< 0 i)
1483       (setq text (cons
1484                   (cons (if (< malyon-story-version 5) i (+ 1 i))
1485                         (malyon-read-byte
1486                          (+ i address (if (< malyon-story-version 5) 0 1))))
1487                   text)
1488             i    (- i 1)))
1489     text))
1490
1491 (defun malyon-text-to-words (address dictionary)
1492   "Turn ztext into a list of dictionary words."
1493   (malyon-characters-to-words
1494    (malyon-encode-character-list (if dictionary dictionary malyon-dictionary)
1495                                  (malyon-text-to-character-list address))))
1496
1497 ;; window management
1498
1499 (defvar malyon-status-buffer-grew-this-turn nil
1500   "A flag signalling if the status buffer grew this turn.")
1501
1502 (defun malyon-adjust-transcript ()
1503   "Adjust the position of the transcript text."
1504   (save-excursion
1505     (setq malyon-status-buffer-grew-this-turn nil)
1506     (set-buffer malyon-transcript-buffer)
1507     (goto-char (point-max))
1508     (recenter (- (malyon-window-displayed-height) 2))))
1509
1510 (defun malyon-prepare-status-buffer (status)
1511   "Fill the status buffer with empty lines."
1512   (save-excursion
1513     (set-buffer malyon-status-buffer)
1514     (let ((lines (count-lines (point-min) (point-max)))
1515           (new   status))
1516       (if (zerop lines)
1517           (newline 1))
1518       (goto-char (point-max))
1519       (setq status (- status lines -1))
1520       (while (> status 0)
1521         (insert (make-string (+ 3 malyon-max-column) ? ))
1522         (newline 1)
1523         (setq status (- status 1)))
1524       (goto-char (point-min))
1525       (forward-line (+ 1 new))
1526       (kill-region (point) (point-max))
1527       (insert (make-string (+ 3 malyon-max-column) ? ))
1528       (newline 1))))
1529
1530 (defun malyon-restore-window-configuration ()
1531   "Restore the saved window configuration."
1532   (let ((buffer (window-buffer (selected-window))))
1533     (if malyon-window-configuration
1534         (set-window-configuration malyon-window-configuration))
1535     (cond ((eq malyon-status-buffer buffer)     (other-window 1))
1536           ((eq malyon-transcript-buffer buffer) (goto-char (point-max))))))
1537
1538 (defun malyon-set-window-configuration (status)
1539   "Set up the new window configuration."
1540   (cond ((< status malyon-status-buffer-lines)
1541          (setq malyon-status-buffer-delayed-split status)
1542          (if malyon-status-buffer-grew-this-turn
1543              (malyon-more-status-buffer)))
1544         ((> status malyon-status-buffer-lines)
1545          (malyon-split-buffer-windows status)
1546          (setq malyon-status-buffer-grew-this-turn t))
1547         ((not malyon-window-configuration)
1548          (malyon-split-buffer-windows status))))
1549
1550 (defun malyon-split-buffer-windows (status)
1551   "Split the buffer windows.
1552 The status buffer gets 'status' lines while the transcript buffer
1553 gets the remaining lines."
1554   (delete-other-windows (get-buffer-window (current-buffer)))
1555   (setq malyon-status-buffer-lines status)
1556   (setq malyon-status-buffer-delayed-split nil)
1557   (if (zerop status)
1558       '()
1559     (split-window (get-buffer-window (current-buffer)) (+ status 3))
1560     (switch-to-buffer malyon-status-buffer)
1561     (malyon-prepare-status-buffer status)
1562     (malyon-opcode-set-cursor 1 1)
1563     (other-window 1))
1564   (switch-to-buffer malyon-transcript-buffer)
1565   (setq malyon-window-configuration (current-window-configuration)))
1566
1567 ;; getting and setting the machine state
1568
1569 (defun malyon-current-game-state ()
1570   "Return the current state of the interpreter."
1571   (vector malyon-instruction-pointer
1572           malyon-stack-pointer
1573           malyon-frame-pointer
1574           (copy-sequence malyon-stack)
1575           (copy-sequence malyon-story-file)
1576           malyon-game-state-quetzal))
1577
1578 (defun malyon-set-game-state (state)
1579   "Installs the given state as the new state of the interpreter."
1580   (setq malyon-instruction-pointer       (aref state 0))
1581   (setq malyon-stack-pointer             (aref state 1))
1582   (setq malyon-frame-pointer             (aref state 2))
1583   (setq malyon-stack (copy-sequence      (aref state 3)))
1584   (setq malyon-story-file (copy-sequence (aref state 4)))
1585   (setq malyon-game-state-quetzal        (aref state 5))
1586   (save-excursion
1587     (malyon-erase-buffer malyon-status-buffer)
1588     (malyon-split-buffer-windows 0)
1589     (setq malyon-last-cursor-position-after-input
1590           (malyon-point-max malyon-transcript-buffer))))
1591
1592 ;; file utilities
1593
1594 (defsubst malyon-write-byte-to-file (byte)
1595   "Write a byte to a file."
1596   (insert-char (logand 255 byte) 1))
1597
1598 (defsubst malyon-write-word-to-file (word)
1599   "Write a word to the last opened file."
1600   (insert-char (logand 255 (lsh word -8)) 1)
1601   (insert-char (logand 255 word) 1))
1602
1603 (defsubst malyon-write-dword-to-file (dword)
1604   "Write a dword to the last opened file."
1605   (insert-char (logand 255 (lsh dword -24)) 1)
1606   (insert-char (logand 255 (lsh dword -16)) 1)
1607   (insert-char (logand 255 (lsh dword -8)) 1)
1608   (insert-char (logand 255 dword) 1))
1609
1610 (defsubst malyon-write-chunk-id-to-file (id)
1611   "Write a quetzal chunk id to the last opened file."
1612   (insert id))
1613
1614 (defsubst malyon-read-byte-from-file ()
1615   "Read the next byte from a file."
1616   (if (= (point) (point-max))
1617       0
1618     (forward-char 1)
1619     (malyon-char-to-int (malyon-char-before))))
1620
1621 (defsubst malyon-read-word-from-file ()
1622   "Read the next word from the last opened file."
1623   (logior (lsh (malyon-read-byte-from-file) 8) (malyon-read-byte-from-file)))
1624
1625 (defsubst malyon-read-dword-from-file ()
1626   "Read the next dword from the last opened file."
1627   (logior (lsh (malyon-read-byte-from-file) 24)
1628           (lsh (malyon-read-byte-from-file) 16)
1629           (lsh (malyon-read-byte-from-file) 8)
1630           (malyon-read-byte-from-file)))
1631
1632 (defsubst malyon-read-chunk-id-from-file ()
1633   "Read a quetzal chunk id from the last opened file."
1634   (string (malyon-int-to-char (malyon-read-byte-from-file))
1635           (malyon-int-to-char (malyon-read-byte-from-file))
1636           (malyon-int-to-char (malyon-read-byte-from-file))
1637           (malyon-int-to-char (malyon-read-byte-from-file))))
1638
1639 (defun malyon-get-file-name (address)
1640   "Retrieves the file name stored at address."
1641   (let ((name (make-string (malyon-read-byte address) ? ))
1642         (i    0))
1643     (while (< i (length name))
1644       (aset name i (malyon-read-byte (+ address 1 i)))
1645       (setq i (+ 1 i)))
1646     name))
1647
1648 ;; saving data to disk
1649
1650 (defun malyon-save-file (file &optional table length)
1651   "Save the current game state or a memory section to disk."
1652   (interactive "FSave file: ")
1653   (condition-case nil
1654       (save-excursion
1655         (set-buffer (create-file-buffer file))
1656         (malyon-disable-multibyte)
1657         (malyon-erase-buffer)
1658         (cond (table (malyon-save-table table length))
1659               (malyon-game-state-quetzal
1660                (malyon-save-quetzal-state (malyon-current-game-state)))
1661               (t
1662                (malyon-save-game-state (malyon-current-game-state))))
1663         (let ((coding-system-for-write 'binary))
1664           (write-file file))
1665         (kill-buffer nil)
1666         1)
1667     (error 0)))
1668
1669 (defun malyon-save-table (table length)
1670   "Save the given section of memory to the file."
1671   (let ((i 0)
1672         (j table))
1673     (while (< i length)
1674       (malyon-write-byte-to-file (malyon-read-byte j))
1675       (setq i (+ 1 i)
1676             j (+ 1 j)))))
1677
1678 (defun malyon-save-game-state (state)
1679   "Saves the game state to disk."
1680   (let ((ip    (aref state 0))
1681         (sp    (aref state 1))
1682         (fp    (aref state 2))
1683         (stack (aref state 3))
1684         (mem   (aref state 4))
1685         (dyn   (malyon-read-word 14))
1686         (i     0))
1687     (malyon-write-word-to-file (length malyon-story-file-name))
1688     (while (< i (length malyon-story-file-name))
1689       (malyon-write-byte-to-file (aref malyon-story-file-name i))
1690       (setq i (+ 1 i)))
1691     (malyon-write-dword-to-file ip)
1692     (malyon-write-word-to-file  sp)
1693     (malyon-write-word-to-file  fp)
1694     (malyon-write-word-to-file  dyn)
1695     (setq i 0)
1696     (while (<= i sp)
1697       (malyon-write-dword-to-file (aref stack i))
1698       (setq i (+ 1 i)))
1699     (setq i 0)
1700     (while (< i dyn)
1701       (malyon-write-byte-to-file (aref mem i))
1702       (setq i (+ 1 i)))))
1703
1704 (defun malyon-save-quetzal-state (state)
1705   "Saves the game state to disk in quetzal format."
1706   (goto-char (point-min))
1707   (malyon-save-quetzal-ifhd state)
1708   (malyon-save-quetzal-cmem state)
1709   (malyon-save-quetzal-stks state)
1710   (goto-char (point-min))
1711   (malyon-write-chunk-id-to-file "IFZS")
1712   (goto-char (point-min))
1713   (malyon-write-dword-to-file (- (point-max) (point-min)))
1714   (goto-char (point-min))
1715   (malyon-write-chunk-id-to-file "FORM"))
1716
1717 (defun malyon-save-quetzal-ifhd (state)
1718   "Saves the IFhd chunk of the quetzal format."
1719   (malyon-write-chunk-id-to-file "IFhd")
1720   (malyon-write-dword-to-file 13)
1721   (malyon-write-word-to-file (malyon-read-word 2))
1722   (malyon-write-word-to-file (malyon-read-word 18))
1723   (malyon-write-word-to-file (malyon-read-word 20))
1724   (malyon-write-word-to-file (malyon-read-word 22))
1725   (malyon-write-word-to-file (malyon-read-word 28))
1726   (malyon-write-byte-to-file (lsh (aref state 0) -16))
1727   (malyon-write-byte-to-file (lsh (aref state 0) -8))
1728   (malyon-write-byte-to-file (aref state 0))
1729   (malyon-write-byte-to-file 0))
1730
1731 (defun malyon-save-quetzal-cmem (state)
1732   "Saves the CMem chunk of the quetzal format."
1733   (let ((beginning (point-max))
1734         (original  (aref malyon-game-state-restart 4))
1735         (current   (aref state 4))
1736         (size      (malyon-read-word 14))
1737         (byte      0)
1738         (count     0)
1739         (i         0))
1740     (goto-char (point-max))
1741     (while (< i size)
1742       (setq byte (logxor (aref current i) (aref original i)))
1743       (if (zerop byte)
1744           (setq count (+ 1 count))
1745         (while (> count 0)
1746           (malyon-write-byte-to-file 0)
1747           (setq count (- count 1))
1748           (malyon-write-byte-to-file (min 255 count))
1749           (setq count (- count (min 255 count))))
1750         (malyon-write-byte-to-file byte))
1751       (setq i (+ 1 i)))
1752     (setq size (- (point-max) beginning))
1753     (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
1754     (goto-char beginning)
1755     (malyon-write-chunk-id-to-file "CMem")
1756     (malyon-write-dword-to-file size)))
1757
1758 (defun malyon-save-quetzal-stks (state)
1759   "Saves the Stks chunk of the quetzal format."
1760   (let ((beginning (point-max))
1761         (size      0))
1762     (goto-char (point-max))
1763     (malyon-save-quetzal-stack-frame (- (aref state 2) 4)
1764                                      (aref state 1)
1765                                      (aref state 3))
1766     (setq size (- (point-max) beginning))
1767     (if (zerop (mod size 2)) '() (malyon-write-byte-to-file 0))
1768     (goto-char beginning)
1769     (malyon-write-chunk-id-to-file "Stks")
1770     (malyon-write-dword-to-file size)))
1771
1772 (defun malyon-save-quetzal-stack-frame (fp sp stack)
1773   "Saves the stack frames for the Stks chunk."
1774   (let* ((frame       (malyon-get-stack-frame fp sp stack))
1775          (frame-id    (aref frame 0))
1776          (previous-fp (aref frame 1))
1777          (previous-sp (aref frame 2))
1778          (return-addr (aref frame 3))
1779          (result-addr (aref frame 4))
1780          (local-vars  (aref frame 5))
1781          (num-args    (aref frame 6))
1782          (eval-stack  (aref frame 7)))
1783     (if (> frame-id 0)
1784         (malyon-save-quetzal-stack-frame previous-fp previous-sp stack))
1785     (malyon-write-byte-to-file (lsh return-addr -16))
1786     (malyon-write-byte-to-file (lsh return-addr -8))
1787     (malyon-write-byte-to-file return-addr)
1788     (if (zerop frame-id)
1789         (malyon-write-byte-to-file 0)
1790       (malyon-write-byte-to-file (logior (if result-addr 0 16)
1791                                          (length local-vars))))
1792     (malyon-write-byte-to-file (if result-addr result-addr 0))
1793     (malyon-write-byte-to-file (- (lsh 1 num-args) 1))
1794     (malyon-write-word-to-file (length eval-stack))
1795     (while (not (null local-vars))
1796       (malyon-write-word-to-file (car local-vars))
1797       (setq local-vars (cdr local-vars)))
1798     (while (not (null eval-stack))
1799       (malyon-write-word-to-file (car eval-stack))
1800       (setq eval-stack (cdr eval-stack)))))
1801
1802 ;; restoring data from disk
1803
1804 (defvar malyon-restore-data-error nil
1805   "An error message if restoring data from a file failed.")
1806
1807 (defvar malyon-restore-quetzal-stack nil
1808   "A temporary stack for restoring quetzal game states.")
1809
1810 (defvar malyon-restore-quetzal-stack-pointer nil
1811   "A temporary stack pointer for restoring quetzal game states.")
1812
1813 (defvar malyon-restore-quetzal-frame-pointer nil
1814   "A temporary frame-pointer for restoring quetzal game states.")
1815
1816 (defun malyon-restore-file (file &optional table length)
1817   "Restore a game state or a memory section from disk."
1818   (interactive "fLoad file: ")
1819   (if (not (and (file-exists-p file) (file-readable-p file)))
1820       0
1821     (condition-case nil
1822         (save-excursion
1823           (setq malyon-restore-data-error nil)
1824           (set-buffer (create-file-buffer file))
1825           (malyon-disable-multibyte)
1826           (malyon-erase-buffer)
1827           (let ((coding-system-for-read 'binary))
1828             (insert-file-contents file))
1829           (goto-char (point-min))
1830           (if table
1831               (malyon-restore-table table length)
1832             (let* ((first  (malyon-read-chunk-id-from-file))
1833                    (second (malyon-read-dword-from-file))
1834                    (third  (malyon-read-chunk-id-from-file)))
1835               (if (and (string= "FORM" first) (string= "IFZS" third))
1836                   (malyon-restore-quetzal-state (+ 8 second))
1837                 (goto-char (point-min))
1838                 (malyon-restore-game-state))))
1839           (kill-buffer nil)
1840           (if (null malyon-restore-data-error)
1841               2
1842             (message malyon-restore-data-error)
1843             0))
1844       (error 0))))
1845
1846 (defun malyon-restore-table (table length)
1847   "Restore the given section of memory from a file."
1848   (let ((i 0)
1849         (j table))
1850     (while (< i length)
1851       (malyon-store-byte j (malyon-read-byte-from-file))
1852       (setq i (+ 1 i)
1853             j (+ 1 j)))))
1854
1855 (defun malyon-restore-game-state ()
1856   "Restore a saved game state from disk."
1857   (let ((len   0)
1858         (name  0)
1859         (story 0)
1860         (ip    0)
1861         (sp    0)
1862         (fp    0)
1863         (dyn   0)
1864         (stack (copy-sequence malyon-stack))
1865         (mem   (copy-sequence malyon-story-file))
1866         (i     0))
1867     (setq len (malyon-read-word-from-file))
1868     (setq name (make-string len ? ))
1869     (while (< i len)
1870       (aset name i (malyon-read-byte-from-file))
1871       (setq i (+ 1 i)))
1872     (setq ip  (malyon-read-dword-from-file))
1873     (setq sp  (malyon-read-word-from-file))
1874     (setq fp  (malyon-read-word-from-file))
1875     (setq dyn (malyon-read-word-from-file))
1876     (setq i 0)
1877     (while (<= i sp)
1878       (aset stack i (malyon-read-dword-from-file))
1879       (setq i (+ 1 i)))
1880     (setq i 0)
1881     (while (< i dyn)
1882       (aset mem i (malyon-read-byte-from-file))
1883       (setq i (+ 1 i)))
1884     (setq name  (file-name-nondirectory name))
1885     (setq story (file-name-nondirectory malyon-story-file-name))
1886     (if (or (string-match name story) (string-match story name))
1887         (malyon-set-game-state (vector ip sp fp stack mem nil))
1888       (setq malyon-restore-data-error "Invalid save file."))))
1889
1890 (defun malyon-restore-quetzal-state (size)
1891   "Restore a saved quetzal game state from disk."
1892   (let ((chunk-id  nil)
1893         (chunk-len 0)
1894         (ip        0)
1895         (memory    nil)
1896         (stack     nil)
1897         (beginning 0))
1898     (while (< (point) size)
1899       (setq chunk-id  (malyon-read-chunk-id-from-file))
1900       (setq chunk-len (malyon-read-dword-from-file))
1901       (setq beginning (point))
1902       (cond ((string= chunk-id "IFhd")
1903              (setq ip (malyon-restore-quetzal-ifhd chunk-len)))
1904             ((string= chunk-id "CMem")
1905              (setq memory (malyon-restore-quetzal-cmem chunk-len)))
1906             ((string= chunk-id "UMem")
1907              (setq memory (malyon-restore-quetzal-umem chunk-len)))
1908             ((string= chunk-id "Stks")
1909              (setq stack (malyon-restore-quetzal-stks chunk-len))))
1910       (if (zerop (mod chunk-len 2)) '() (setq chunk-len (+ 1 chunk-len)))
1911       (goto-char (+ beginning chunk-len)))
1912     (cond ((and ip memory stack)
1913            (malyon-set-game-state (vector ip
1914                                           (aref stack 0)
1915                                           (aref stack 1)
1916                                           (aref stack 2)
1917                                           memory
1918                                           t)))
1919           ((null malyon-restore-data-error)
1920            (setq malyon-restore-data-error "invalid quetzal file.")))))
1921
1922 (defun malyon-restore-quetzal-ifhd (size)
1923   "Restore an IFhd chunk from disk. Return the instruction pointer."
1924   (if (and (= (malyon-read-word-from-file) (malyon-read-word 2))
1925            (= (malyon-read-word-from-file) (malyon-read-word 18))
1926            (= (malyon-read-word-from-file) (malyon-read-word 20))
1927            (= (malyon-read-word-from-file) (malyon-read-word 22))
1928            (= (malyon-read-word-from-file) (malyon-read-word 28)))
1929       (logior (lsh (malyon-read-byte-from-file) 16)
1930               (lsh (malyon-read-byte-from-file) 8)
1931               (malyon-read-byte-from-file))
1932     (setq malyon-restore-data-error "quetzal file doesn't belong to game.")
1933     nil))
1934
1935 (defun malyon-restore-quetzal-cmem (size)
1936   "Restore a CMem chunk from disk. Return the entire memory layout."
1937   (let ((memory   (copy-sequence (aref malyon-game-state-restart 4)))
1938         (max-size (+ (point) size))
1939         (byte     0)
1940         (i        0))
1941     (while (< (point) max-size)
1942       (setq byte (malyon-read-byte-from-file))
1943       (if (zerop byte)
1944           (setq i (+ 1 i (malyon-read-byte-from-file)))
1945         (aset memory i (logxor byte (aref memory i)))
1946         (setq i (+ 1 i))))
1947     memory))
1948
1949 (defun malyon-restore-quetzal-umem (size)
1950   "Restore a UMem chunk from disk. Return the entire memory layout."
1951   (let ((memory (copy-sequence (aref malyon-game-state-restart 4)))
1952         (i      0))
1953     (while (< i size)
1954       (aset memory i (malyon-read-byte-from-file))
1955       (setq i (+ 1 i)))
1956     memory))
1957
1958 (defun malyon-restore-quetzal-stks (size)
1959   "Restore a Stks chunk from disk. Return a vector containing the
1960 stack pointer, the frame pointer, and the stack itself."
1961   (let ((i 0) (frame-id 0))
1962     (setq malyon-restore-quetzal-stack
1963           (copy-sequence (aref malyon-game-state-restart 3)))
1964     (setq malyon-restore-quetzal-stack-pointer -1)
1965     (setq malyon-restore-quetzal-frame-pointer 2)
1966     (while (< i size)
1967       (let* ((beginning     (point))
1968              (return3       (malyon-read-byte-from-file))
1969              (return2       (malyon-read-byte-from-file))
1970              (return1       (malyon-read-byte-from-file))
1971              (return-addr   (logior (lsh return3 16) (lsh return2 8) return1))
1972              (result-locals (malyon-read-byte-from-file))
1973              (has-result    (zerop (logand 16 result-locals)))
1974              (num-locals    (logand 15 result-locals))
1975              (result-addr   (malyon-read-byte-from-file))
1976              (arg-flags     (+ 1 (malyon-read-byte-from-file)))
1977              (num-args      0)
1978              (eval-size     (malyon-read-word-from-file))
1979              (local-vars    '())
1980              (eval-stack    '()))
1981         (while (> num-locals 0)
1982           (setq local-vars (cons (malyon-read-word-from-file) local-vars))
1983           (setq num-locals (- num-locals 1)))
1984         (while (> eval-size 0)
1985           (setq eval-stack (cons (malyon-read-word-from-file) eval-stack))
1986           (setq eval-size (- eval-size 1)))
1987         (while (> arg-flags 1)
1988           (setq arg-flags (lsh arg-flags -1))
1989           (setq num-args (+ num-args 1)))
1990         (malyon-push-stack-frame frame-id
1991                                  return-addr
1992                                  (if (zerop frame-id)
1993                                      nil
1994                                    (if has-result result-addr nil))
1995                                  (reverse local-vars)
1996                                  num-args
1997                                  (reverse eval-stack))
1998         (setq frame-id (+ 1 frame-id))
1999         (setq i (+ i (- (point) beginning)))))
2000     (vector malyon-restore-quetzal-stack-pointer
2001             malyon-restore-quetzal-frame-pointer
2002             malyon-restore-quetzal-stack)))
2003
2004 ;; object table management
2005
2006 (defsubst malyon-object-address (object)
2007   "Compute the address at which the object is stored."
2008   (+ malyon-object-table
2009      (* 2 malyon-object-properties)
2010      (* malyon-object-table-entry-size (- object 1))))
2011
2012 (defsubst malyon-object-read-parent (address)
2013   "Return the parent."
2014   (if (< malyon-story-version 5)
2015       (malyon-read-byte (+ 4 address))
2016     (malyon-read-word (+ 6 address))))
2017
2018 (defsubst malyon-object-read-sibling (address)
2019   "Return the next sibling."
2020   (if (< malyon-story-version 5)
2021       (malyon-read-byte (+ 5 address))
2022     (malyon-read-word (+ 8 address))))
2023
2024 (defsubst malyon-object-read-child (address)
2025   "Return the first child."
2026   (if (< malyon-story-version 5)
2027       (malyon-read-byte (+ 6 address))
2028     (malyon-read-word (+ 10 address))))
2029
2030 (defsubst malyon-object-store-parent (address value)
2031   "Set the parent."
2032   (if (< malyon-story-version 5)
2033       (malyon-store-byte (+ 4 address) value)
2034     (malyon-store-word (+ 6 address) value)))
2035
2036 (defsubst malyon-object-store-sibling (address value)
2037   "Set the next sibling."
2038   (if (< malyon-story-version 5)
2039       (malyon-store-byte (+ 5 address) value)
2040     (malyon-store-word (+ 8 address) value)))
2041
2042 (defsubst malyon-object-store-child (address value)
2043   "Set the first child."
2044   (if (< malyon-story-version 5)
2045       (malyon-store-byte (+ 6 address) value)
2046     (malyon-store-word (+ 10 address) value)))
2047
2048 (defun malyon-find-property (object property)
2049   "Return the address of the object's property, or 0 if it doesn't exist."
2050   (let ((next (malyon-first-property object))
2051         (number 0))
2052     (setq number (logand (malyon-read-byte next) malyon-object-properties))
2053     (while (> number property)
2054       (setq next (malyon-next-property next))
2055       (setq number (logand (malyon-read-byte next) malyon-object-properties)))
2056     (if (= number property) next 0)))
2057
2058 (defun malyon-first-property (object)
2059   "Get the address of the object's first property."
2060   (let ((header (malyon-read-word (+ malyon-object-property-offset
2061                                      (malyon-object-address object)))))
2062     (+ header 1 (* 2 (malyon-read-byte header)))))
2063
2064 (defun malyon-next-property (property)
2065   "Get the address of the following property."
2066   (let ((size (malyon-read-byte property))
2067         (addr (+ property 1)))
2068     (+ 1 addr (cond ((< malyon-story-version 5) (lsh size -5))
2069                     ((zerop (logand 128 size))  (lsh size -6))
2070                     (t
2071                      (let ((second (logand 63 (malyon-read-byte addr))))
2072                        (if (= 0 second) 64 second)))))))
2073
2074 (defun malyon-remove-object (object)
2075   "Remove the object from the children list of its parent."
2076   (let* ((address (malyon-object-address object))
2077          (parent  (malyon-object-read-parent address))
2078          (sibling (malyon-object-read-sibling address)))
2079     (malyon-object-store-parent address 0)
2080     (malyon-object-store-sibling address 0)
2081     (if (/= parent 0)
2082         (let ((parent-addr (malyon-object-address parent)))
2083           (let ((children (malyon-object-read-child parent-addr)))
2084             (if (or (= children 0) (= children object))
2085                 (malyon-object-store-child parent-addr sibling)
2086               (let ((this (malyon-object-address children)))
2087                 (let ((next (malyon-object-read-sibling this)))
2088                   (while (/= next object)
2089                     (setq this (malyon-object-address next))
2090                     (setq next (malyon-object-read-sibling this)))
2091                   (malyon-object-store-sibling this sibling)))))))))
2092
2093 ;; function calls and code branches
2094
2095 (defun malyon-call-routine (routine arguments &optional result)
2096   "Call a routine with the given arguments and return its result."
2097   (if (= routine 0)
2098       (if result (malyon-store-variable result 0) 0)
2099     (malyon-push-stack (if result 0 1))
2100     (malyon-push-stack (if result result 0))
2101     (malyon-push-stack malyon-instruction-pointer)
2102     (malyon-push-stack
2103      (logior (lsh (- malyon-stack-pointer malyon-frame-pointer) 8)
2104              (length arguments)))
2105     (setq malyon-instruction-pointer (* malyon-packed-multiplier routine))
2106     (let ((args (malyon-read-code-byte)) (value nil))
2107       (if malyon-game-state-quetzal
2108           (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
2109             (malyon-push-stack (logior (lsh (+ 1 id) 8) args))))
2110       (setq malyon-frame-pointer malyon-stack-pointer)
2111       (while (> args 0)
2112         (setq value (if (< malyon-story-version 5) (malyon-read-code-word) 0))
2113         (malyon-push-stack (if (null arguments) value (car arguments)))
2114         (setq arguments (cdr arguments))
2115         (setq args (- args 1))))))
2116
2117 (defun malyon-jump-if (condition)
2118   "Jump depending on the condition and the following jump data."
2119   (let ((byte   (malyon-read-code-byte))
2120         (offset nil)
2121         (iftrue nil))
2122     (setq iftrue (/= 0 (logand byte 128)))
2123     (setq offset (logand byte 63))
2124     (if (= 0 (logand byte 64))
2125         (progn
2126           (setq offset (logior (lsh offset 8) (malyon-read-code-byte)))
2127           (if (>= offset 8192) (setq offset (- offset 16384)))))
2128     (if (or (and iftrue condition) (and (not iftrue) (not condition)))
2129         (progn
2130           (cond ((= offset 0) (malyon-opcode-rfalse))
2131                 ((= offset 1) (malyon-opcode-rtrue))
2132                 (t            (setq
2133                                malyon-instruction-pointer
2134                                (+ malyon-instruction-pointer offset -2))))))))
2135
2136 (defun malyon-return (value)
2137   "Return from a routine."
2138   (setq malyon-stack-pointer malyon-frame-pointer)
2139   (if malyon-game-state-quetzal (malyon-pop-stack))
2140   (setq malyon-frame-pointer
2141         (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
2142   (setq malyon-instruction-pointer (malyon-pop-stack))
2143   (let ((result (malyon-pop-stack))
2144         (store  (malyon-pop-stack)))
2145     (if (zerop store)
2146         (malyon-return-store result value)
2147       (malyon-return-ignore result value))))
2148
2149 (defun malyon-return-ignore (where value)
2150   "Return from a routine ignoring the result.")
2151
2152 (defun malyon-return-store (where value)
2153   "Return from a routine storing the result."
2154   (malyon-store-variable where value))
2155
2156 (defun malyon-push-initial-frame ()
2157   "Push the initial stack frame required in quetzal mode."
2158   (if malyon-game-state-quetzal
2159       (progn
2160         (malyon-push-stack 1)
2161         (malyon-push-stack 0)
2162         (malyon-push-stack 0)
2163         (malyon-push-stack 0)
2164         (malyon-push-stack 0))))
2165
2166 (defun malyon-get-stack-frame (fp sp stack)
2167   "Return a decoded stack frame in quetzal mode.
2168 The result is a vector containing the frame id, the fp of the
2169 previous frame, the sp of the previous frame, the return address,
2170 the result variable if any, a list of local variables, the number
2171 of arguments, and a list of the evaluation stack elements."
2172   (let* ((has-result   (zerop (aref stack fp)))
2173          (result-addr  (if has-result (aref stack (+ 1 fp)) nil))
2174          (return-addr  (aref stack (+ 2 fp)))
2175          (offset       (lsh (aref stack (+ 3 fp)) -8))
2176          (num-args     (logand 255 (aref stack (+ 3 fp))))
2177          (frame-id     (lsh (aref stack (+ 4 fp)) -8))
2178          (num-locals   (logand 255 (aref stack (+ 4 fp))))
2179          (start-locals (+ 5 fp))
2180          (start-eval   (+ 5 fp num-locals))
2181          (local-vars   '())
2182          (eval-stack   '()))
2183     (if (not (zerop num-locals))
2184         (setq local-vars
2185               (malyon-vector-to-list stack start-locals start-eval)))
2186     (if (> sp start-eval)
2187         (setq eval-stack
2188               (malyon-vector-to-list stack start-eval (+ 1 sp))))
2189     (vector frame-id
2190             (- fp offset 2)
2191             (- fp 1)
2192             return-addr
2193             result-addr
2194             local-vars
2195             num-args
2196             eval-stack)))
2197
2198 (defsubst malyon-restore-quetzal-push-stack (value)
2199   "Push a value onto the restore quetzal stack."
2200   (setq malyon-restore-quetzal-stack-pointer
2201         (+ malyon-restore-quetzal-stack-pointer 1))
2202   (aset malyon-restore-quetzal-stack
2203         malyon-restore-quetzal-stack-pointer
2204         value))
2205
2206 (defun malyon-push-stack-frame
2207   (frame-id return-addr result local-vars num-args eval-stack)
2208   "Pushes a new stack frame in quetzal mode."
2209   (malyon-restore-quetzal-push-stack (if result 0 1))
2210   (malyon-restore-quetzal-push-stack (if result result 0))
2211   (malyon-restore-quetzal-push-stack return-addr)
2212   (malyon-restore-quetzal-push-stack
2213    (logior (lsh (- malyon-restore-quetzal-stack-pointer
2214                    malyon-restore-quetzal-frame-pointer) 8)
2215            num-args))
2216   (malyon-restore-quetzal-push-stack
2217    (logior (lsh frame-id 8) (length local-vars)))
2218   (setq malyon-restore-quetzal-frame-pointer
2219         malyon-restore-quetzal-stack-pointer)
2220   (while (not (null local-vars))
2221     (malyon-restore-quetzal-push-stack (car local-vars))
2222     (setq local-vars (cdr local-vars)))
2223   (while (not (null eval-stack))
2224     (malyon-restore-quetzal-push-stack (car eval-stack))
2225     (setq eval-stack (cdr eval-stack))))
2226
2227 ;; other stuff
2228
2229 (defvar malyon-aread-text nil
2230   "Text buffer for user input.")
2231
2232 (defvar malyon-aread-parse nil
2233   "Parse buffer for user input.")
2234
2235 (defvar malyon-aread-beginning-of-line nil
2236   "The beginning of the input line.")
2237
2238 ;; execution
2239
2240 (defun malyon-interpreter ()
2241   "Run the z code interpreter on the given story file."
2242 ;  (condition-case nil
2243       (progn
2244         (malyon-restore-window-configuration)
2245         (if malyon-story-file
2246             (catch 'malyon-end-of-interpreter-loop
2247               (setq malyon-last-cursor-position-after-input
2248                     (malyon-point-max malyon-transcript-buffer))
2249               (malyon-execute))))
2250 ;    (error
2251 ;     (malyon-fatal-error "unspecified internal runtime error."))))
2252 )
2253 (defsubst malyon-fetch-variable-operands (specifier)
2254   "Fetch a variable number of operands based on the specifier argument."
2255   (let ((var  (logand specifier 49152))
2256         (op   '()))
2257     (setq specifier (logand 65535 specifier))
2258     (while (/= 0 specifier)
2259       (cond ((= var 0)     (setq op (cons (malyon-read-code-word) op)))
2260             ((= var 16384) (setq op (cons (malyon-read-code-byte) op)))
2261             ((= var 32768) (setq op (cons (malyon-read-variable
2262                                            (malyon-read-code-byte)) op)))
2263             (t             (setq specifier 0)))
2264       (setq specifier (logand 65535 (lsh specifier 2)))
2265       (setq var  (logand specifier 49152)))
2266     (nreverse op)))
2267
2268 (defsubst malyon-fetch-extended (opcode)
2269   "Fetch operands for an extended instruction."
2270   (malyon-fetch-variable-operands
2271    (logior (lsh (malyon-read-code-byte) 8) 255)))
2272
2273 (defsubst malyon-fetch-variable (opcode)
2274   "Fetch operands for a variable instruction."
2275   (malyon-fetch-variable-operands
2276    (if (or (= opcode 236) (= opcode 250))
2277        (malyon-read-code-word)
2278      (logior (lsh (malyon-read-code-byte) 8) 255))))
2279
2280 (defsubst malyon-fetch-short (opcode)
2281   "Fetch operands for a short instruction."
2282   (let ((op (logand opcode 48)))
2283     (cond ((= op 0)  (list (malyon-read-code-word)))
2284           ((= op 16) (list (malyon-read-code-byte)))
2285           ((= op 32) (list (malyon-read-variable (malyon-read-code-byte)))))))
2286
2287 (defsubst malyon-fetch-long (instr)
2288   "Fetch operands for a long instruction."
2289   (let ((byte1 (malyon-read-code-byte))
2290         (byte2 (malyon-read-code-byte)))
2291     (list (if (= (logand instr 64) 0) byte1 (malyon-read-variable byte1))
2292           (if (= (logand instr 32) 0) byte2 (malyon-read-variable byte2)))))
2293
2294 (defun malyon-execute ()
2295   "Execute z code instructions.
2296 Load the next instruction opcode and its operands and execute it.
2297 Repeat ad infinitum."
2298   (let ((opcode) (operands)); (pc))
2299     (while t
2300 ;      (setq pc malyon-instruction-pointer)
2301       (setq opcode (malyon-read-code-byte))
2302       (setq operands (cond ((=  opcode 190)
2303                             (setq opcode (+ 256 (malyon-read-code-byte)))
2304                             (malyon-fetch-extended opcode))
2305                            ((>= opcode 192)
2306                             (malyon-fetch-variable opcode))
2307                            ((>= opcode 128)
2308                             (malyon-fetch-short opcode))
2309                            (t
2310                             (malyon-fetch-long opcode))))
2311 ;      (malyon-trace-opcode pc opcode operands)
2312       (apply (aref malyon-opcodes opcode) operands))))
2313
2314 ;; opcodes
2315
2316 (defsubst malyon-number (n)
2317   "Convert an unsigned number into a signed one."
2318   (if (< n 32768) n (- n 65536)))
2319
2320 (defun malyon-opcode-add (a b)
2321   "Addition."
2322   (malyon-store-variable (malyon-read-code-byte)
2323                          (+ (malyon-number a) (malyon-number b))))
2324
2325 (defun malyon-opcode-and (a b)
2326   "Bitwise and."
2327   (malyon-store-variable (malyon-read-code-byte) (logand a b)))
2328
2329 (defun malyon-opcode-aread (text parse &optional time routine)
2330   "Read input text."
2331   (setq malyon-aread-text text)
2332   (setq malyon-aread-parse parse)
2333   (goto-char (point-max))
2334   (setq malyon-aread-beginning-of-line (point))
2335 ; Some games violate these assumptions for the "Quit" question.
2336 ;  (if (> 3 (malyon-read-byte text))
2337 ;      (malyon-fatal-error "text buffer less than 3 bytes."))
2338 ;  (if (and (not (zerop parse)) (> 2 (malyon-read-byte parse)))
2339 ;      (malyon-fatal-error "parse buffer less than 2 bytes."))
2340   (malyon-more malyon-keymap-read)
2341   (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-input))
2342
2343 (defun malyon-opcode-art-shift (value places)
2344   "Arithmetic shift."
2345   (malyon-store-variable (malyon-read-code-byte) (ash value places)))
2346
2347 (defun malyon-opcode-buffer-mode (mode)
2348   "Toggles buffering of text in the transcript window."
2349   (setq malyon-transcript-buffer-buffered (/= 0 mode)))
2350
2351 (defun malyon-opcode-calln (routine &rest arguments)
2352   "Call a routine and ignore the result."
2353   (malyon-call-routine routine arguments))
2354
2355 (defun malyon-opcode-calls (routine &rest arguments)
2356   "Call a routine and store the result."
2357   (malyon-call-routine routine arguments (malyon-read-code-byte)))
2358
2359 (defun malyon-opcode-catch ()
2360   "Return the current stack frame."
2361   (malyon-store-variable
2362    (malyon-read-code-byte)
2363    (if malyon-game-state-quetzal
2364        (lsh (aref malyon-stack malyon-frame-pointer) -8)
2365      malyon-frame-pointer)))
2366
2367 (defun malyon-opcode-check-arg-count (count)
2368   "Tests the number of arguments passed to routine."
2369   (malyon-jump-if
2370    (<= count (logand 255 (aref malyon-stack
2371                                (if malyon-game-state-quetzal
2372                                    (- malyon-frame-pointer 1)
2373                                  malyon-frame-pointer))))))
2374
2375 (defun malyon-opcode-check-unicode (char)
2376   "Check whether the given character is valid for input/output."
2377   (malyon-store-variable (malyon-read-code-byte) 0))
2378
2379 (defun malyon-opcode-clear-attr (object attribute)
2380   "Clear the given attribute in the given object."
2381   (let ((attributes (malyon-object-address object))
2382         (byte       (lsh attribute -3)))
2383     (malyon-store-byte (+ attributes byte)
2384                        (logand (malyon-read-byte (+ attributes byte))
2385                                (logxor (lsh 128 (- (logand attribute 7)))
2386                                        255)))))
2387
2388 (defun malyon-opcode-copy-table (first second size)
2389   "Copies first table onto second one."
2390   (let* ((length  (abs (malyon-number size)))
2391          (zero    (zerop second))
2392          (forward (or (< (malyon-number size) 0) (> first second)))
2393          (i       0)
2394          (a       (if forward first (+ first length -1)))
2395          (b       (if forward (if zero first second) (+ second length -1))))
2396     (while (< i length)
2397       (malyon-store-byte b (if zero 0 (malyon-read-byte a)))
2398       (setq i (+ i 1)
2399             a (if forward (+ a 1) (- a 1))
2400             b (if forward (+ b 1) (- b 1))))))
2401
2402 (defun malyon-opcode-dec (var)
2403   "Decrement variable."
2404   (malyon-store-variable var
2405                          (- (malyon-number (malyon-read-variable var)) 1)))
2406
2407 (defun malyon-opcode-dec-chk (variable threshold)
2408   "Decrement variable and jump if it's less than the given value."
2409   (let ((value (malyon-number (malyon-read-variable variable))))
2410     (malyon-store-variable variable (- value 1))
2411     (malyon-jump-if (< (- value 1) (malyon-number threshold)))))
2412
2413 (defun malyon-opcode-div (a b)
2414   "Division."
2415   (if (zerop b) (malyon-fatal-error "division by 0."))
2416   (malyon-store-variable (malyon-read-code-byte)
2417                          (/ (malyon-number a) (malyon-number b))))
2418
2419 (defun malyon-opcode-encode-text (text length from encoded)
2420   "Encode the zscii text starting at from with the given length.
2421 The result is stored at encoded."
2422   (let* ((i     length)
2423          (j     encoded)
2424          (l     '())
2425          (word  '()))
2426     (while (< 0 i)
2427       (setq l (cons (malyon-read-byte (+ text from i -1)) l)
2428             i (- i 1)))
2429     (setq word (malyon-encode-dictionary-word
2430                 (append (malyon-mapcan 'malyon-encode-into-ztext l)
2431                         '(5 5 5 5 5 5 5 5))))
2432     (while (< i 6)
2433       (malyon-store-byte j (car l))
2434       (setq i (+ 1 i)
2435             j (+ 1 j)
2436             l (cdr word)))))
2437
2438 (defun malyon-opcode-erase-line (value)
2439   "Erases the rest of the line."
2440   (if (= value 1)
2441       (if (eq malyon-transcript-buffer (current-buffer))
2442           (kill-line nil)
2443         (save-excursion
2444           (let ((i (current-column)))
2445             (while (<= i malyon-max-column)
2446               (insert ? )
2447               (delete-char 1)
2448               (setq i (+ 1 i))))))))
2449
2450 (defun malyon-opcode-erase-window (window)
2451   "Erase the contents of the given window."
2452   (save-excursion
2453     (let ((w (malyon-number window)))
2454       (if (or (= w 0) (= w -1) (= w -2))
2455           (malyon-erase-buffer malyon-transcript-buffer))
2456       (if (or (= w 1) (= w -1) (= w -2))
2457           (malyon-erase-buffer malyon-status-buffer))
2458       (if (= w -1)
2459           (malyon-split-buffer-windows 0)))
2460     (setq malyon-last-cursor-position-after-input
2461           (malyon-point-max malyon-transcript-buffer))))
2462
2463 (defun malyon-opcode-get-child (object)
2464   "Get the first child of the given object and jump."
2465   (let ((child (malyon-object-read-child (malyon-object-address object))))
2466     (malyon-store-variable (malyon-read-code-byte) child)
2467     (malyon-jump-if (/= 0 child))))
2468
2469 (defun malyon-opcode-get-cursor (array)
2470   "Retrieves the current cursor position."
2471   (save-excursion
2472     (set-buffer malyon-status-buffer)
2473     (malyon-store-word array (- (count-lines (point-min) (point)) 1))
2474     (malyon-store-word (+ 2 array) (+ 1 (current-column)))))
2475
2476 (defun malyon-opcode-get-next-prop (object property)
2477   "Retrieve the first or next property id of object."
2478   (let ((next (malyon-first-property object))
2479         (number 0))
2480     (if (zerop property)
2481         '()
2482       (setq number (logand (malyon-read-byte next)
2483                            malyon-object-properties))
2484       (setq next (malyon-next-property next))
2485       (while (> number property)
2486         (setq number (logand (malyon-read-byte next)
2487                              malyon-object-properties))
2488         (setq next (malyon-next-property next)))
2489       (if (/= number property)
2490           (malyon-fatal-error "property does not exist.")))
2491     (setq number (logand (malyon-read-byte next) malyon-object-properties))
2492     (malyon-store-variable (malyon-read-code-byte) number)))
2493
2494 (defun malyon-opcode-get-parent (object)
2495   "Get the parent of the given object."
2496   (malyon-store-variable (malyon-read-code-byte)
2497                          (malyon-object-read-parent
2498                           (malyon-object-address object))))
2499
2500 (defun malyon-opcode-get-prop (object property)
2501   "Get the value of the object's property."
2502   (let* ((address (malyon-find-property object property))
2503          (size    (malyon-read-byte address)))
2504     (malyon-store-variable
2505      (malyon-read-code-byte)
2506      (cond ((zerop address)
2507             (malyon-read-word (+ malyon-object-table (* 2 (- property 1)))))
2508            ((and (<  malyon-story-version 5) (zerop (lsh size -5)))
2509             (malyon-read-byte (+ address 1)))
2510            ((and (>= malyon-story-version 5) (zerop (logand 192 size)))
2511             (malyon-read-byte (+ address 1)))
2512            (t
2513             (malyon-read-word (+ address 1)))))))
2514
2515 (defun malyon-opcode-get-prop-addr (object property)
2516   "Get the address of the object's property."
2517   (let* ((address (malyon-find-property object property))
2518          (size    (malyon-read-byte address))
2519          (offset  (if (< malyon-story-version 5)
2520                       1
2521                     (if (zerop (logand 128 size)) 1 2))))
2522     (malyon-store-variable (malyon-read-code-byte)
2523                            (if (zerop address) 0 (+ address offset)))))
2524
2525 (defun malyon-opcode-get-prop-len (property)
2526   "Get the length of the object's property."
2527   (let ((size (malyon-read-byte (- property 1))))
2528     (malyon-store-variable
2529      (malyon-read-code-byte)
2530      (cond ((< malyon-story-version 5) (+ 1 (lsh size -5)))
2531            ((zerop (logand 128 size))  (+ 1 (lsh size -6)))
2532            ((zerop (logand  63 size))  64)
2533            (t                          (logand 63 size))))))
2534
2535 (defun malyon-opcode-get-sibling (object)
2536   "Get the next object in the tree and jump."
2537   (let ((sibling (malyon-object-read-sibling (malyon-object-address object))))
2538     (malyon-store-variable (malyon-read-code-byte) sibling)
2539     (malyon-jump-if (/= 0 sibling))))
2540
2541 (defun malyon-opcode-illegal (&rest ignore)
2542   "Print an error message and exit the interpreter."
2543   (malyon-fatal-error "illegal opcode."))
2544
2545 (defun malyon-opcode-inc (var)
2546   "Increment variable."
2547   (malyon-store-variable var
2548                          (+ (malyon-number (malyon-read-variable var)) 1)))
2549
2550 (defun malyon-opcode-inc-chk (variable threshold)
2551   "Increment variable and jump if it's greater than the given value."
2552   (let ((value (malyon-number (malyon-read-variable variable))))
2553     (malyon-store-variable variable (+ value 1))
2554     (malyon-jump-if (> (+ value 1) (malyon-number threshold)))))
2555
2556 (defun malyon-opcode-input-stream (number)
2557   "Select the given input stream. Only the keyboard is supported."
2558   (if (zerop (malyon-number number))
2559       '()
2560     (message "Only the keyboard is supported as an input stream.")))
2561
2562 (defun malyon-opcode-insert-obj (object destination)
2563   "Insert an object into the children list of another."
2564   (let ((child  (malyon-object-address object))
2565         (parent (malyon-object-address destination)))
2566     (malyon-remove-object object)
2567     (malyon-object-store-parent  child destination)
2568     (malyon-object-store-sibling child (malyon-object-read-child parent))
2569     (malyon-object-store-child   parent object)))
2570
2571 (defun malyon-opcode-je (a &rest rest)
2572   "Jump if first operand equals any of the following."
2573   (malyon-jump-if (member (malyon-number a) (mapcar 'malyon-number rest))))
2574
2575 (defun malyon-opcode-jg (a b)
2576   "Jump if first operand > second operand."
2577   (malyon-jump-if (> (malyon-number a) (malyon-number b))))
2578
2579 (defun malyon-opcode-jin (child parent)
2580   "Jump if second object is parent of the first one."
2581     (malyon-jump-if
2582      (= parent (malyon-object-read-parent (malyon-object-address child)))))
2583
2584 (defun malyon-opcode-jl (a b)
2585   "Jump if first operand < second operand."
2586   (malyon-jump-if (< (malyon-number a) (malyon-number b))))
2587
2588 (defun malyon-opcode-jump (offset)
2589   "Jump unconditionally."
2590   (setq malyon-instruction-pointer (+ malyon-instruction-pointer
2591                                       (malyon-number offset) -2)))
2592
2593 (defun malyon-opcode-jz (a)
2594   "Jump if operand = 0."
2595   (malyon-jump-if (zerop a)))
2596
2597 (defun malyon-opcode-load (variable)
2598   "Load a variable."
2599   (malyon-store-variable (malyon-read-code-byte)
2600                          (malyon-read-variable variable)))
2601
2602 (defun malyon-opcode-loadb (array index)
2603   "Load an array element into a variable."
2604   (malyon-store-variable (malyon-read-code-byte)
2605                          (malyon-read-byte (+ array index))))
2606
2607 (defun malyon-opcode-loadw (array index)
2608   "Load an array element into a variable."
2609   (malyon-store-variable (malyon-read-code-byte)
2610                          (malyon-read-word (+ array (* 2 index)))))
2611
2612 (defun malyon-opcode-log-shift (value places)
2613   "Logical shift."
2614   (malyon-store-variable (malyon-read-code-byte) (lsh value places)))
2615
2616 (defun malyon-opcode-mod (a b)
2617   "Modulo."
2618   (malyon-store-variable (malyon-read-code-byte)
2619                          (mod (malyon-number a) (malyon-number b))))
2620
2621 (defun malyon-opcode-mul (a b)
2622   "Multiplication."
2623   (malyon-store-variable (malyon-read-code-byte)
2624                          (* (malyon-number a) (malyon-number b))))
2625
2626 (defun malyon-opcode-new-line ()
2627   "Print a newline."
2628   (malyon-newline))
2629
2630 (defun malyon-opcode-nop (&rest ignore)
2631   "Do nothing.")
2632
2633 (defun malyon-opcode-not (a)
2634   "Bitwise not."
2635   (malyon-store-variable (malyon-read-code-byte) (logand 65535 (lognot a))))
2636
2637 (defun malyon-opcode-or (a b)
2638   "Bitwise or."
2639   (malyon-store-variable (malyon-read-code-byte) (logior a b)))
2640
2641 (defun malyon-opcode-output-stream (stream &optional table)
2642   "Select an output stream."
2643   (let ((stream (malyon-number stream)))
2644     (cond ((< 0 stream) (malyon-add-output-stream stream table))
2645           ((> 0 stream) (malyon-remove-output-stream (- stream))))))
2646
2647 (defun malyon-opcode-piracy ()
2648   "Piracy check, effectively an unconditional jump."
2649   (malyon-jump-if 1))
2650
2651 (defun malyon-opcode-print ()
2652   "Print a string."
2653   (setq malyon-instruction-pointer
2654         (malyon-print-text malyon-instruction-pointer)))
2655
2656 (defun malyon-opcode-print-addr (address)
2657   "Print a string."
2658   (malyon-print-text address))
2659
2660 (defun malyon-opcode-print-char (c)
2661   "Print a character."
2662   (malyon-print (char-to-string c)))
2663
2664 (defun malyon-opcode-print-num (n)
2665   "Print a number."
2666   (malyon-print (number-to-string (malyon-number n))))
2667
2668 (defun malyon-opcode-print-obj (obj)
2669   "Print the short name of the object."
2670   (malyon-print-text
2671    (+ 1 (malyon-read-word (+ malyon-object-property-offset
2672                              (malyon-object-address obj))))))
2673
2674 (defun malyon-opcode-print-paddr (address)
2675   "Print a string."
2676   (malyon-print-text (* malyon-packed-multiplier address)))
2677
2678 (defun malyon-opcode-print-ret ()
2679   "Print a string, print a newline, return true/1."
2680   (setq malyon-instruction-pointer
2681         (malyon-print-text malyon-instruction-pointer))
2682   (malyon-newline)
2683   (malyon-return 1))
2684
2685 (defun malyon-opcode-print-table (text width &optional height skip)
2686   "Print the given table."
2687   (if (not height) (setq height 1))
2688   (if (not skip)   (setq skip 0))
2689   (let ((column  (current-column))
2690         (address text)
2691         (y       0)
2692         (x       0))
2693     (while (< y height)
2694       (if (zerop y)
2695           '()
2696         (malyon-newline)
2697         (malyon-print-characters (make-string column ? )))
2698       (setq x 0)
2699       (while (< x width)
2700         (malyon-output-character (malyon-read-byte address))
2701         (setq address (+ 1 address))
2702         (setq x (+ 1 x)))
2703       (setq address (+ skip address))
2704       (setq y (+ 1 y)))))
2705
2706 (defun malyon-opcode-print-unicode (char)
2707   "Prints a unicode character.")
2708
2709 (defun malyon-opcode-pull (variable)
2710   "Pull value off stack."
2711   (malyon-store-variable variable (malyon-pop-stack)))
2712
2713 (defun malyon-opcode-push (value)
2714   "Push value onto stack."
2715   (malyon-push-stack value))
2716
2717 (defun malyon-opcode-put-prop (object property value)
2718   "Set the object's property to the given value."
2719   (let* ((address (malyon-find-property object property))
2720          (size    (malyon-read-byte address)))
2721     (cond ((= address 0)
2722            (malyon-fatal-error "property does not exist."))
2723           ((and (<  malyon-story-version 5) (zerop (lsh size -5)))
2724            (malyon-store-byte (+ 1 address) (logand 255 value)))
2725           ((and (>= malyon-story-version 5) (zerop (logand size 192)))
2726            (malyon-store-byte (+ 1 address) (logand 255 value)))
2727           (t
2728            (malyon-store-word (+ 1 address) value)))))
2729
2730 (defun malyon-opcode-quit ()
2731   "End the game immediately."
2732   (malyon-adjust-transcript)
2733   (malyon-cleanup)
2734   (throw 'malyon-end-of-interpreter-loop 'malyon-opcode-quit))
2735
2736 (defun malyon-opcode-random (limit)
2737   "Generate a random number or set the seed value."
2738   (malyon-store-variable (malyon-read-code-byte)
2739                          (if (>= 0 (malyon-number limit))
2740                              0
2741                            (+ 1 (random (malyon-number limit))))))
2742
2743 (defun malyon-opcode-read-char (&optional device &rest ignore)
2744   "Read a character."
2745   (if (and device (/= 1 device))
2746       (malyon-fatal-error "illegal device specified in read_char."))
2747   (if (eq malyon-transcript-buffer (current-buffer))
2748       (goto-char (point-max)))
2749   (message "[Press a key.]")
2750   (malyon-more malyon-keymap-readchar)
2751   (throw 'malyon-end-of-interpreter-loop 'malyon-waiting-for-character))
2752
2753 (defun malyon-opcode-remove-obj (object)
2754   "Remove an object from its parent's children list."
2755   (malyon-remove-object object))
2756
2757 (defun malyon-opcode-restart ()
2758   "Restart the game."
2759   (malyon-set-game-state malyon-game-state-restart))
2760
2761 (defun malyon-opcode-restore (&optional table bytes name)
2762   "Restore a saved game state or a section of memory from a file."
2763   (let ((result (if name
2764                     (malyon-restore-file
2765                      (malyon-get-file-name name) table bytes)
2766                   (call-interactively 'malyon-restore-file))))
2767     (if (< malyon-story-version 5)
2768         (malyon-jump-if (not (zerop result)))
2769       (malyon-store-variable (malyon-read-code-byte) result))))
2770
2771 (defun malyon-opcode-restore-undo ()
2772   "Restore game state for undo."
2773   (if malyon-game-state-undo
2774       (malyon-set-game-state malyon-game-state-undo))
2775   (malyon-store-variable (malyon-read-code-byte) 2))
2776
2777 (defun malyon-opcode-ret (value)
2778   "Return a value."
2779   (malyon-return value))
2780
2781 (defun malyon-opcode-ret-popped ()
2782   "Return top of stack."
2783   (malyon-return (malyon-pop-stack)))
2784
2785 (defun malyon-opcode-rfalse ()
2786   "Return false/0."
2787   (malyon-return 0))
2788
2789 (defun malyon-opcode-rtrue ()
2790   "Return true/1."
2791   (malyon-return 1))
2792
2793 (defun malyon-opcode-save (&optional table bytes name)
2794   "Save the current game state or a section of memory to a file."
2795   (let ((result (if name
2796                     (malyon-save-file (malyon-get-file-name name) table bytes)
2797                   (call-interactively 'malyon-save-file))))
2798     (if (< malyon-story-version 5)
2799         (malyon-jump-if (not (zerop result)))
2800       (malyon-store-variable (malyon-read-code-byte) result))))
2801
2802 (defun malyon-opcode-save-undo ()
2803   "Save game state for undo."
2804   (setq malyon-game-state-undo (malyon-current-game-state))
2805   (malyon-store-byte (malyon-read-code-byte) 1))
2806
2807 (defun malyon-opcode-scan-table (x table len &optional form)
2808   "Scan the given table for the first occurrence of x."
2809   (if (not form) (setq form 130))
2810   (let ((inc (logand 127 form))
2811         (byte (zerop (logand 128 form)))
2812         (addr table)
2813         (found 0)
2814         (index 0))
2815     (while (and (zerop found) (< index len))
2816       (setq found
2817             (if byte
2818                 (if (= x (malyon-read-byte addr)) addr 0)
2819               (if (= x (malyon-read-word addr)) addr 0)))
2820       (setq addr (+ addr inc))
2821       (setq index (+ index 1)))
2822     (malyon-store-variable (malyon-read-code-byte) found)
2823     (malyon-jump-if (not (zerop found)))))
2824
2825 (defun malyon-opcode-set-attr (object attribute)
2826   "Set the given attribute in the given object."
2827   (let ((attributes (malyon-object-address object))
2828         (byte       (lsh attribute -3)))
2829     (malyon-store-byte (+ attributes byte)
2830                        (logior (malyon-read-byte (+ attributes byte))
2831                                (lsh 128 (- (logand attribute 7)))))))
2832
2833 (defun malyon-opcode-set-color (foreground background)
2834   "Sets the fore- and background colors ie. does nothing.")
2835
2836 (defun malyon-opcode-set-cursor (&optional line column)
2837   "Set the cursor."
2838   (if (eq malyon-transcript-buffer (current-buffer))
2839       (goto-char (point-max))
2840     (if malyon-status-buffer-delayed-split
2841         (progn
2842           (malyon-split-buffer-windows malyon-status-buffer-delayed-split)
2843           (other-window 1)))
2844     (if line   '() (setq line   (count-lines (point-min) (point))))
2845     (if column '() (setq column (current-column)))
2846     (if (> line malyon-status-buffer-lines)
2847         (progn
2848           (malyon-split-buffer-windows line)
2849           (other-window 1)))
2850     (goto-char (point-min))
2851     (if (and (<= 1 line) (<= line malyon-status-buffer-lines))
2852         (forward-line line)
2853       (beginning-of-line))
2854     (if (and (<= 1 column) (<= column malyon-max-column))
2855         (forward-char (- column 1))
2856       (beginning-of-line))
2857     (setq malyon-status-buffer-point (point))))
2858
2859 (defun malyon-opcode-set-font (font)
2860   "Sets the font if available or 0 otherwise."
2861   (malyon-store-variable (malyon-read-code-byte) 0))
2862
2863 (defun malyon-opcode-set-text-style (style)
2864   "Set the text style/face."
2865   (let ((face (assq style malyon-faces)))
2866     (setq malyon-current-face (if face (cdr face) 'malyon-face-plain))))
2867
2868 (defun malyon-opcode-set-window (window)
2869   "Set the current window."
2870   (malyon-restore-window-configuration)
2871   (setq malyon-current-window window)
2872   (malyon-update-output-streams)
2873   (if (zerop window)
2874       (if (not (eq malyon-transcript-buffer (current-buffer)))
2875           (other-window 1))
2876     (if (not (eq malyon-status-buffer (current-buffer)))
2877         (other-window 1))
2878     (malyon-opcode-set-cursor 1 1)))
2879
2880 (defun malyon-opcode-show-status ()
2881   "Display the status line."
2882   (save-excursion
2883     (malyon-opcode-split-window 1)
2884     (malyon-restore-window-configuration)
2885     (malyon-opcode-set-window 1)
2886     (malyon-prepare-status-buffer 1)
2887     (malyon-opcode-set-cursor 1 1)
2888     (malyon-opcode-print-obj (malyon-read-global-variable 0))
2889     (if (<= (current-column) (- (current-fill-column) 10))
2890         (let* ((x     (malyon-read-global-variable 1))
2891                (y     (malyon-read-global-variable 2))
2892                (hours (if (> x 12) (- x 12) x))
2893                (ampm  (if (> x 12) "PM" "AM"))
2894                (score (format "%4d/%4d" x y))
2895                (time  (format "%02d:%02d%s" hours y ampm)))
2896           (malyon-opcode-set-cursor 1 (- (current-fill-column) 10))
2897           (malyon-print (if malyon-score-game score time))))
2898     (malyon-opcode-set-window 0)
2899     (malyon-adjust-transcript)))
2900
2901 (defun malyon-opcode-split-window (size)
2902   "Split upper and lower window."
2903   (malyon-set-window-configuration size))
2904
2905 (defun malyon-opcode-store (variable value)
2906   "Store a value in a variable."
2907   (malyon-store-variable variable value))
2908
2909 (defun malyon-opcode-storeb (array index value)
2910   "Store a value in an array at the given index."
2911   (malyon-store-byte (+ array index) value))
2912
2913 (defun malyon-opcode-storew (array index value)
2914   "Store a value in an array at the given index."
2915   (malyon-store-word (+ array (* 2 index)) value))
2916
2917 (defun malyon-opcode-sub (a b)
2918   "Subtraction."
2919   (malyon-store-variable (malyon-read-code-byte)
2920                          (- (malyon-number a) (malyon-number b))))
2921
2922 (defun malyon-opcode-test (bitmap flags)
2923   "Test if all of the flags are set in the bitmap."
2924   (malyon-jump-if (= flags (logand bitmap flags))))
2925
2926 (defun malyon-opcode-test-attr (object attribute)
2927   "Jump depending on the given attribute in the given object."
2928   (malyon-jump-if
2929    (/= 0 (logand (malyon-read-byte (+ (malyon-object-address object)
2930                                       (lsh attribute -3)))
2931                  (lsh 128 (- (logand attribute 7)))))))
2932
2933 (defun malyon-opcode-throw (value frame)
2934   "Return from the given stack frame."
2935   (if malyon-game-state-quetzal
2936       (let ((id (lsh (aref malyon-stack malyon-frame-pointer) -8)))
2937         (while (/= frame id)
2938           (setq malyon-stack-pointer malyon-frame-pointer)
2939           (malyon-pop-stack)
2940           (setq malyon-frame-pointer
2941                 (- malyon-stack-pointer 1 (lsh (malyon-pop-stack) -8)))
2942           (malyon-pop-stack)
2943           (malyon-pop-stack)
2944           (setq id (lsh (aref malyon-stack malyon-frame-pointer) -8))))
2945     (setq malyon-frame-pointer frame))
2946   (malyon-return value))
2947
2948 (defun malyon-opcode-tokenise (text parse &optional dict flag)
2949   "Perform lexical analysis on the text buffer."
2950   (let* ((words (malyon-text-to-words text dict))
2951          (word  (car           words))
2952          (start (car           word))
2953          (len   (malyon-cadr   word))
2954          (code  (malyon-caddr  word))
2955          (entry (malyon-lookup dict code))
2956          (i     0))
2957     (while (not (or (null words) (= i (malyon-read-byte parse))))
2958       (if (and (zerop entry) flag (/= 0 flag))
2959           '()
2960         (malyon-store-word (+ 2 parse (* 4 i)) entry)
2961         (malyon-store-byte (+ 4 parse (* 4 i)) len)
2962         (malyon-store-byte (+ 5 parse (* 4 i)) start))
2963       (setq words (cdr           words)
2964             word  (car           words)
2965             start (car           word)
2966             len   (malyon-cadr   word)
2967             code  (malyon-caddr  word)
2968             entry (malyon-lookup dict code)
2969             i     (+ 1 i)))
2970     (malyon-store-byte (+ 1 parse) i)))
2971
2972 (defun malyon-opcode-verify ()
2973   "Verify the correctness of the story file."
2974   (let ((length (+ 1 (* malyon-packed-multiplier (malyon-read-word 26))))
2975         (sum    0)
2976         (i      64))
2977     (while (< i length)
2978       (setq sum (mod (+ sum (malyon-read-byte i)) 65536)
2979             i   (+ 1 i)))
2980     (malyon-jump-if (= (malyon-read-word 28) sum))))
2981
2982 ;; keymap utilities
2983
2984 (defun malyon-end-input ()
2985   "Store the input line in a text buffer and perform lexical analysis."
2986   (interactive)
2987   (condition-case nil
2988       (progn
2989         (malyon-adjust-transcript)
2990         (switch-to-buffer malyon-transcript-buffer)
2991         (goto-char (point-max))
2992         (let* ((input (downcase
2993                        (buffer-substring-no-properties
2994                         (if (< malyon-aread-beginning-of-line (point))
2995                             malyon-aread-beginning-of-line
2996                           (point))
2997                         (point))))
2998                (vec  (malyon-string-to-vector input))
2999                (text (apply 'vector (mapcar 'malyon-unicode-to-zscii vec)))
3000                (len  (min (malyon-read-byte malyon-aread-text) (length text)))
3001                (i    0))
3002           (malyon-history-insert input)
3003           (if (>= malyon-story-version 5)
3004               (malyon-store-byte (+ malyon-aread-text 1) len))
3005           (while (< i len)
3006             (malyon-store-byte
3007              (+ malyon-aread-text (if (< malyon-story-version 5) 1 2) i)
3008              (malyon-char-to-int (aref text i)))
3009             (setq i (+ 1 i)))
3010           (if (< malyon-story-version 5)
3011               (malyon-store-byte (+ malyon-aread-text 1 len) 0)))
3012         (if (/= 0 malyon-aread-parse)
3013             (malyon-opcode-tokenise malyon-aread-text malyon-aread-parse))
3014         (newline)
3015         (if (>= malyon-story-version 5)
3016             (malyon-store-variable (malyon-read-code-byte) 10))
3017         (malyon-interpreter))
3018     (error
3019      (malyon-fatal-error "unspecified internal runtime error."))))
3020
3021 (defun malyon-more-char ()
3022   "Page down in More mode."
3023   (interactive)
3024   (condition-case nil
3025       (scroll-up)
3026     (error))
3027   (if (>= (count-lines (point) (point-max))
3028           (malyon-window-displayed-height))
3029       (message "[More]")
3030     (goto-char (point-max))
3031     (malyon-adjust-transcript)
3032     (use-local-map malyon-more-continue-keymap)))
3033
3034 (defun malyon-more-char-status ()
3035   "Wait for a key then continue."
3036   (interactive)
3037   (condition-case nil
3038       (progn
3039         (malyon-adjust-transcript)
3040         (use-local-map malyon-more-continue-keymap)
3041         (malyon-interpreter))
3042     (error
3043      (malyon-fatal-error "unspecified internal runtime error."))))
3044
3045 (defun malyon-wait-char ()
3046   "Store the input character in a variable and resume execution."
3047   (interactive)
3048   (condition-case nil
3049       (progn
3050         (malyon-store-variable
3051          (malyon-read-code-byte)
3052          (malyon-char-to-int (malyon-unicode-to-zscii last-command-char)))
3053         (use-local-map malyon-keymap-read)
3054         (malyon-interpreter))
3055     (error
3056      (malyon-fatal-error "unspecified internal runtime error."))))
3057
3058 (defun malyon-history-previous-char (arg)
3059   "Display the previous item in the input history."
3060   (interactive "p")
3061   (let ((input (malyon-history-previous)))
3062     (cond ((> malyon-aread-beginning-of-line (point))
3063            (funcall malyon-history-saved-up arg))
3064           (input
3065            (save-excursion
3066              (set-buffer malyon-transcript-buffer)
3067              (delete-region malyon-aread-beginning-of-line (point-max)))
3068            (goto-char (point-max))
3069            (insert input)
3070            (malyon-adjust-transcript)))))
3071
3072 (defun malyon-history-next-char (arg)
3073   "Display the next item in the input history."
3074   (interactive "p")
3075   (let ((input (malyon-history-next)))
3076     (cond ((> malyon-aread-beginning-of-line (point))
3077            (funcall malyon-history-saved-down arg))
3078           (input
3079            (save-excursion
3080              (set-buffer malyon-transcript-buffer)
3081              (delete-region malyon-aread-beginning-of-line (point-max)))
3082            (goto-char (point-max))
3083            (insert input)
3084            (malyon-adjust-transcript)))))
3085
3086 (defun malyon-beginning-of-line (arg)
3087   "Go to the beginning of the line."
3088   (interactive "p")
3089   (if (> malyon-aread-beginning-of-line (point))
3090       (beginning-of-line)
3091     (goto-char malyon-aread-beginning-of-line)))
3092
3093 (defun malyon-kill-region (arg)
3094   "Kill region."
3095   (interactive "p")
3096   (if (<= malyon-aread-beginning-of-line (point))
3097       (kill-region (point) (mark))
3098     (message "Editing is restricted to the input prompt.")))
3099
3100 (defun malyon-kill-line (arg)
3101   "Kill rest of the current line."
3102   (interactive "p")
3103   (if (<= malyon-aread-beginning-of-line (point))
3104       (kill-line)
3105     (message "Editing is restricted to the input prompt.")))
3106
3107 (defun malyon-kill-word (arg)
3108   "Kill the current word."
3109   (interactive "p")
3110   (if (<= malyon-aread-beginning-of-line (point))
3111       (kill-word 1)
3112     (message "Editing is restricted to the input prompt.")))
3113
3114 (defun malyon-yank (arg)
3115   "Yank."
3116   (interactive "p")
3117   (if (<= malyon-aread-beginning-of-line (point))
3118       (yank)
3119     (message "Editing is restricted to the input prompt.")))
3120
3121 (defun malyon-yank-pop (arg)
3122   "Yank pop."
3123   (interactive "p")
3124   (if (<= malyon-aread-beginning-of-line (point))
3125       (yank-pop 1)
3126     (message "Editing is restricted to the input prompt.")))
3127
3128 (defun malyon-delete-char (arg)
3129   "Delete a character."
3130   (interactive "p")
3131   (if (<= malyon-aread-beginning-of-line (point))
3132       (delete-char 1)
3133     (message "Editing is restricted to the input prompt.")))
3134
3135 (defun malyon-backward-delete-char (arg)
3136   "Delete a character backwards."
3137   (interactive "p")
3138   (if (< malyon-aread-beginning-of-line (point))
3139       (backward-delete-char-untabify 1)
3140     (message "Editing is restricted to the input prompt.")))
3141
3142 (defun malyon-self-insert-command (arg)
3143   "Insert a character."
3144   (interactive "p")
3145   (if (> malyon-aread-beginning-of-line (point))
3146       (goto-char (point-max)))
3147   (self-insert-command 1))
3148
3149 ;; tracing utility
3150
3151 (defun malyon-trace-file ()
3152   "Turn tracing on for a particular file."
3153   (let ((trace
3154          (get-buffer-create
3155           (concat "Malyon Trace " malyon-story-file-name))))
3156     (if trace
3157         (save-excursion
3158           (set-buffer trace)
3159           (malyon-erase-buffer)
3160           (insert (concat "Tracing " malyon-story-file-name "..."))
3161           (newline)))))
3162
3163 (defun malyon-trace-newline ()
3164   "Output tracing newline."
3165   (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
3166     (if trace
3167         (save-excursion
3168           (set-buffer trace)
3169           (goto-char (point-max))
3170           (newline)))))
3171
3172 (defun malyon-trace-opcode (pc opcode operands)
3173   "Output a z code instruction."
3174   (malyon-trace-string
3175    (format "%8d   %-3d %-25s %s\n"
3176            pc
3177            opcode
3178            (symbol-name (aref malyon-opcodes opcode))
3179            (apply 'concat (malyon-mapcan
3180                            (lambda (x)
3181                              (list " "
3182                                    (number-to-string
3183                                     (if (malyon-characterp x)
3184                                         (malyon-char-to-int x)
3185                                       x))))
3186                            operands)))))
3187
3188 (defun malyon-trace-string (s)
3189   "Output tracing string."
3190   (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
3191     (if (and trace s)
3192         (save-excursion
3193           (set-buffer trace)
3194           (goto-char (point-max))
3195           (insert s)))))
3196
3197 (defun malyon-trace-object (o)
3198   "Output tracing object."
3199   (let ((trace (get-buffer (concat "Malyon Trace " malyon-story-file-name))))
3200     (if (and trace o)
3201         (save-excursion
3202           (set-buffer trace)
3203           (goto-char (point-max))
3204           (prin1 o trace)))))
3205
3206 ;;; announce malyon-mode
3207
3208 (provide 'malyon-mode)
3209 (provide 'malyon)
3210
3211 ;;; malyon-mode.el ends here