X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=ez.git;a=blobdiff_plain;f=ez.el;h=a6f1f9c4dcbec63c5815a1f75858328130f38c33;hp=65990b7b7690bb8ebf7c799e5509faf933a766b7;hb=HEAD;hpb=fcb66a431dd743fd06547505ab8476d7d961f853 diff --git a/ez.el b/ez.el index 65990b7..a6f1f9c 100644 --- a/ez.el +++ b/ez.el @@ -1,8 +1,8 @@ ;;; ez.el --- Emacs Z-machine -;; Copyright (C) 2021 Tim Vaughan +;; Copyright (C) 2021,2022,2023 Tim Vaughan -;; Author: Tim Vaughan +;; Author: Tim Vaughan ;; Created: 13 Oct 2021 ;; Version: 1.0 ;; Keywords: game @@ -84,15 +84,33 @@ (defvar ez-abbrevtab-addr nil) (defvar ez-globalvartab-addr nil) +(defvar ez-dict-entries nil + "Parsed dictionary") + +(defvar ez-dict-separators nil + "Parsed dictionary") + (defun ez-mem-ref-byte (addr) (aref ez-memory addr)) +(defun ez-mem-ref-bytes (addr count) + (mapcar (lambda (offset) (ez-mem-ref-byte (+ addr offset))) + (number-sequence 0 (- count 1)))) + (defun ez-mem-set-byte (addr val) (aset ez-memory addr val)) +(defun ez-mem-set-bytes (addr vals) + (dotimes (i (length vals)) + (ez-mem-set-byte (+ addr i) (elt vals i)))) + (defun ez-mem-ref-word (addr) - (+ (* 256 (aref ez-memory addr)) - (aref ez-memory (+ addr 1)))) + (logior (lsh (aref ez-memory addr) 8) + (aref ez-memory (+ addr 1)))) + +(defun ez-mem-ref-words (addr count) + (mapcar (lambda (offset) (ez-mem-ref-word (+ addr offset))) + (number-sequence 0 (- (* 2 count) 1) 2))) (defun ez-mem-set-word (addr val) (let ((byte-high (/ val 256)) @@ -100,6 +118,9 @@ (aset ez-memory addr byte-high) (aset ez-memory (+ addr 1) byte-low))) +(defun ez-mem-ref-string (addr1 addr2) + (substring ez-memory addr1 addr2)) + (defun ez-parse-header () (setq ez-version (ez-mem-ref-byte #x0)) (setq ez-himem-addr (ez-mem-ref-word #x4)) @@ -274,6 +295,12 @@ (logand (lsh word -5) #b11111) (logand word #b11111))) +(defun ez-make-zstring-word (zchar-triple) + (let ((c1 (elt zchar-triple 0)) + (c2 (elt zchar-triple 1)) + (c3 (elz zchar-triple 2))) + (logand ))) + (defun ez-get-zstring-chars-and-length (base-addr) (let ((addr base-addr) (chars nil) @@ -294,31 +321,114 @@ (chars (cdr word-count-and-chars)) (cur 0) (lock 0) - (abbrev-char nil) (s "")) - (dolist (char chars) - (cond - (abbrev-char - (let ((abbrev-addr - (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr - (* 2 (+ (* (- abbrev-char 1) 32) char))))))) - (setq s (concat s (cdr (ez-get-zstring-and-length abbrev-addr))))) - (setq abbrev-char nil)) - ((memq char '(1 2 3)) ;Abbreviation - (setq abbrev-char char)) - ((= char 4) - (setq cur (mod (+ cur 1) 3))) - ((= char 5) - (setq cur (mod (+ 3 (- cur 1)) 3))) - (t - (setq s (concat s (substring (elt ez-zstring-alphabets cur) - char (+ char 1)))) - (setq cur lock)))) + (while (> (length chars) 0) + (let ((char (pop chars))) + (cond + ((memq char '(1 2 3)) ;Abbreviation + (let* ((abbrev-char char) + (abbrev-addr + (* 2 (ez-mem-ref-word (+ ez-abbrevtab-addr + (* 2 (+ (* (- abbrev-char 1) 32) (pop chars)))))))) + (setq s (concat s (cdr (ez-get-zstring-and-length abbrev-addr)))))) + ((= char 4) + (setq cur (mod (+ cur 1) 3))) + ((= char 5) + (setq cur (mod (+ 3 (- cur 1)) 3))) + ((and (= cur 2) (= char 6)) + (setq s (concat s (char-to-string (+ (lsh (pop chars) 5) (pop chars))))) + (setq cur lock)) + (t + (setq s (concat s (substring (elt ez-zstring-alphabets cur) + char (+ char 1)))) + (setq cur lock))))) (cons word-count s))) (defun ez-get-zstring (base-addr) (cdr (ez-get-zstring-and-length base-addr))) +(defun ez-encode (string) + "Encodes a string as a 2-word 5-padded Z-string. +Used for matching input with dictionary entries when tokenizing. +Returns a length-2 list of words for comparison with a dictionary entry." + (let ((chars + (mapcan + (lambda (c) + (cond + ((seq-contains-p (elt ez-zstring-alphabets 0) c) + (list (seq-position (elt ez-zstring-alphabets 0) c))) + ((seq-contains-p (elt ez-zstring-alphabets 1) c) + (list 4 (seq-position (elt ez-zstring-alphabets 1) c))) + ((seq-contains-p (elt ez-zstring-alphabets 2) c) + (list 5 (seq-position (elt ez-zstring-alphabets 2) c))) + (t + (list 5 6 (lsh c -5) (logand c #b11111))))) + string))) + (let* ((zstring-chars + (if (< (length chars) 6) + (append chars (make-list (- 6 (length chars)) 5)) + (take 6 chars))) + (c1 (elt zstring-chars 0)) + (c2 (elt zstring-chars 1)) + (c3 (elt zstring-chars 2)) + (c4 (elt zstring-chars 3)) + (c5 (elt zstring-chars 4)) + (c6 (elt zstring-chars 5))) + (list + (logior (lsh c1 10) + (lsh c2 5) + c3) + (logior (lsh 1 15) + (lsh c4 10) + (lsh c5 5) + c6))))) + +;; Dictionary + +(defun ez-parse-dictionary-header () + (let* ((nseps (ez-mem-ref-byte ez-dict-base)) + (separators + (mapcar (lambda (i) (ez-mem-ref-byte (+ ez-dict-base i))) + (number-sequence 1 nseps))) + (bytes-per-entry (ez-mem-ref-byte (+ ez-dict-base 1 nseps))) + (nentries (ez-mem-ref-word (+ ez-dict-base 2 nseps))) + (entries-base (+ ez-dict-base nseps 4)) + (entries nil)) + ;; (dotimes (i nentries) + ;; (let ((this-base (+ entries-base (* bytes-per-entry i)))) + ;; (setq entries (cons (cons (ez-get-zstring this-base) + ;; this-base) + ;; entries)))) + ;; (setq ez-dict-entries (reverse entries)) + (setq ez-dict-separators separators))) + +(defun ez-is-separator (char) + (let* ((nseps (ez-mem-ref-byte ez-dict-base))) + (while (and (> nseps 0) + (not (= (ez-mem-ref-byte (+ ez-dict-base nseps)) + char))) + (setq nseps (- nseps 1))) + (> nseps 0))) + +(defun ez-lookup-dictionary (text) + (let* ((encoded-text (ez-encode text)) + (nseps (ez-mem-ref-byte ez-dict-base)) + (bytes-per-entry (ez-mem-ref-byte (+ ez-dict-base 1 nseps))) + (nentries (ez-mem-ref-word (+ ez-dict-base 2 nseps))) + (entries-seen 0) + (this-entry (+ ez-dict-base nseps 4))) + + (while (and (< entries-seen nentries) + (not (equal + (ez-mem-ref-words this-entry 2) + encoded-text))) + (setq entries-seen (+ entries-seen 1)) + (setq this-entry (+ this-entry bytes-per-entry))) + + (if (< entries-seen nentries) + this-entry + 0))) + ;; Call stack (defvar ez-call-stack nil) @@ -848,11 +958,50 @@ 'wait-for-input) (defun ez-op-read2 (input-string) - (ez-tokenize-string input-string - (car ez--next-read-args) - (cadr ez--next-read-args)) + (let* ((baddr1 (car ez--next-read-args)) + (baddr2 (cadr ez--next-read-args))) + + (dotimes (i (length input-string)) + (let ((char (elt input-string i))) + (ez-mem-set-byte (+ baddr1 1 i) char))) + (ez-mem-set-byte (+ baddr1 1 (length input-string)) 0) + + (ez--tokenize baddr1 baddr2)) 'run) +(defun ez--tokenize (tb-baddr pb-baddr) + + (let ((unfinished t) + (token-start 0) + (token-end 0) + (token-count 0)) + + (while unfinished + (let ((next-char (ez-mem-ref-byte (+ tb-baddr 1 token-end)))) + (cond + ((eq next-char ?\s) + ;; Add token + (setq token-end (- token-end 1)) + (let* ((text (ez-mem-ref-string (+ tb-baddr 1 token-start) + (+ tb-baddr 1 token-end))) + (dict-entry (ez-lookup-dictionary text))) + (setq token-count (+ token-count 1)) + (ez-mem-set-word (+ pb-baddr 2 (* token-count 4)) + dict-entry) + (ez-mem-set-bytes (+ pb-baddr 2 (* token-count 4) 2) + (length text) + token-start)) + (setq token-start (+ token-end 1)) + (setq token-end token-start)) + + ((ez-is-separator char) + ;; Add token and separator token + ) + ((eq char 0) + (setq unfinished nil)) + (setq token-end (+ token-end 1))) + )))) + ;; Execution loop (defun ez-load-and-run (filename) @@ -898,8 +1047,10 @@ (interactive) (if (not (eq ez-machine-state 'wait-for-input)) (error "Z-machine not ready for input.")) - (let ((input-string (with-current-buffer "*ez*" - (buffer-substring ez-input-marker (point-max))))) + (let ((input-string + (downcase + (with-current-buffer "*ez*" + (buffer-substring ez-input-marker (point-max)))))) (delete-region ez-input-marker (point-max)) (ez-print (concat input-string "\n")) (ez-debug-message "\tReceived string \"%s\"" input-string) @@ -928,7 +1079,8 @@ (setq-local buffer-read-only t) (let ((inhibit-read-only t) (old-point (point))) - (hexl-mode-exit) + (if (eq major-mode 'hexl-mode) + (hexl-mode-exit)) (erase-buffer) (insert ez-memory) (setq-local buffer-undo-list nil)