;MMC-LMC - This is the Meta-Machine Code targeted at the Little Man Computer. ;Copyright (C) 2020 Prince Trippy . ;This program is free software: you can redistribute it and/or modify it under the terms of the ;GNU Affero General Public License version 3 as published by the Free Software Foundation. ;This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without ;even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;See the GNU Affero General Public License for more details. ;You should have received a copy of the GNU Affero General Public License along with this program. ;If not, see . (cl:defpackage #:mmc-lmc (:use #:common-lisp #:shut-it-down #:acute-terminal-control) (:import-from #:cl-ecma-48 #:erase-in-line #:erase-in-page #:set-mode #:reset-mode) (:documentation "This is an advanced, interactive development tool for the Little Man Computer.") (:shadow #:delete)) (cl:in-package #:mmc-lmc) (defmacro with-hidden-cursor (&rest progn) "Execute the body with the cursor made invisible during." `(unwind-protect (progn (reset-mode '(#.(code-char 63) 25)) ,@progn) (set-mode '(#.(code-char 63) 25)))) (defun use-color (use-color) "This functions gates (SETF ATC:FOREGROUND) so that it may be easily disabled if this be desired." (prog1 nil #-no-color (setf (foreground) use-color))) (defun get-rows (&optional (last rows) (stream *standard-output*) &aux (*standard-output* stream)) (declare (special rows)) "Return the number of rows the display has available." (with-hidden-cursor (or (first (dimensions)) last))) (deftype octet () '(unsigned-byte 8)) (defconstant home 17 "This is the home position of the cursor for a row of the display.") (defconstant maximum-name-length 9 "A name may be no greater in length than nine characters.") (defconstant maximum-name-amount 100 "There may be no more than one hundred names in the system.") (defvar rows (load-time-value (get-rows 25)) "This is the current number of display rows.") (defvar current-row 1 "This is the current and active row of the display.") (defvar current nil "This is the current double cons.") (defvar top nil "This is the double cons corresponding to the top of the display.") (defparameter value-name-display-property :underlined "This value is given to ATC:PROPERTIES to determine how name associations are shown in SHOW-ROW. Alternative values for this special symbol include the following: :BOLD, :ITALICS, or :NEGATIVE") (defvar integer-key-translation (pairlis #-qwerty (coerce "aoeuidhtns" 'list) #+qwerty (coerce "asdfghjkl;" 'list) (coerce "1234567890" 'list) (pairlis #-qwerty (coerce "',.pyfgcrl;qjkxbmwvz" 'list) #+qwerty (coerce "qwertyuiopzxcvbnm,e/" 'list) (make-list 20 :initial-element #\Newline))) "This is the association list containing special keyboard translations for integer asking.") (defvar name-identifier-digits-translation "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789 " ;(coerce (nconc (loop :for character := #\A :then (code-char (1+ (char-code character))) ; :until (> (char-code character) (char-code #\Z)) ; :collecting character :collecting (char-downcase character)) ; (coerce "0123456789 " 'list)) ; 'string) "This string determines the ordering of characters to character codes in the external format. It is alternating upper case and lower case Latin alphabet letters followed by the decimals.") (defparameter names () "This is the global list of names known to the system for searching purposes. I've found there's little purpose to avoiding such a global value.") (define-condition refuse () () (:documentation "This condition is signalled when asking functions entirely decline to answer.") (:report "A function has declined to answer a question.")) (defstruct (name (:predicate namep)) "A name represents a quantity no larger than three digits. A name which truly designates an address, a label, points directly to the internal representation." (identifier "" :type string) (value 0 :type (or d:cons (integer 0 999)))) (defstruct (instruction (:predicate instructionp)) "An instruction is three digits: a command digit, and two address digits." (C 0 :type (integer 0 9)) (NN 0 :type (or name (integer 0 99)))) ;Beware of any large name errors. (setf (symbol-function 'C) #'instruction-C) (defun labelp (name) "This predicate returns true if the name designates a label." (d:consp (name-value name))) (defun address (cons) "Return the address of the chosen CONS, by counting from the CBR." (nth-value 0 (d:length cons 'd:cbr))) (defun resolve-name-value (name) "Return the integer value of a name." (if (integerp (name-value name)) (name-value name) (address (name-value name)))) (defun resolve-to-value (resolve-to-value) "Resolve a name or an integer to its integer value." (etypecase resolve-to-value (integer resolve-to-value) (name (resolve-name-value resolve-to-value)))) (defun resolve-name-id (string) "Return a name, based on the identifier string, if it exists in the global namespace, else NIL." (find string names :key 'name-identifier :test 'string=)) (defun NN (instruction &aux (NN (instruction-NN instruction))) "Return the NN field of an instruction." (if (integerp NN) NN (resolve-name-value NN))) (defun make-field (&optional (length 100)) "This creates the combined program and metadata space of the MMC." (apply 'd:list (loop :repeat length :collecting (list (make-instruction :C 0 :NN 0))))) (defun backspace (&optional (count 1) (stream *standard-output*)) "Erase COUNT characters with spaces, as would be expected." (dotimes (ignore count) (declare (ignorable ignore)) (write-sequence #(#\Backspace #\Space #\Backspace) stream))) (defun read-character-event (&optional (stream *standard-output*) &aux (*standard-output* stream)) "Read from the higher event stream, until a character event occurs. The event (:META . #\Space) will be translated to the #\Escape character." (loop (finish-output) (let ((read-event (read-event))) (if (equal '(:meta . #\Space) read-event) (return #.(code-char 27))) ;It's really but a hack. (and (characterp read-event) (> 128 (char-code read-event)) (return read-event))))) (defun ask-limited-line (length &optional (return 'identity) (stream *standard-output*) &aux (*standard-output* stream) (string (make-array length :element-type 'character :fill-pointer 0))) "Read a single line, of a string of characters, limited in length. The RETURN is a predicate designator, returning true when the line is acceptable, default IDENTITY." (erase-in-line) (unwind-protect (progn (use-color :magenta) (loop (let ((character (read-character-event))) (case character (#.(code-char 27) (signal 'refuse)) ((#\Newline #\Return #\Linefeed) (if (funcall return string) (return string))) ((#\Backspace #\Rubout) (if (ignore-errors (vector-pop string)) (backspace))) (t (and (or (alphanumericp character) (char= #\Space character)) (vector-push character string) (write-char character))))))) (use-color :default))) (defun ask-integer (max default &optional name (return 'identity) (stream *standard-output*) &aux (*standard-output* stream) (integer 0) (name-value (if (namep default) (resolve-name-value default) default)) (string (make-array 3 :element-type 'character :fill-pointer 0)) (namestring (make-array maximum-name-length :element-type 'character :fill-pointer 0))) "Read an integer value between zero and MAX, inclusive, or a name designating such a value. Empty input results in the default. When reading a name, this behaves as ASK-LIMITED-LINE. If that NAME argument be true, this begins in that mode. Importantly, RETURN will be called on a name value, not a string as with ASK-LIMITED-LINE." (assert (>= max name-value) (max) "The default value, ~A, for ASK-INTEGER mustn't exceed the maximum accepted." name-value) (erase-in-line) (unwind-protect (progn (use-color :magenta) (loop (or name (not (zerop (length string))) (use-color '(:rgb 128 128 128)) ;Defaults are shown using a gray. (format t "~3,'0D~:[~;!~]" name-value (namep default)) (use-color :magenta) (write-sequence #(#\Backspace #\Backspace #\Backspace #\Backspace) *standard-output* :end (if (namep default) 4 3))) (let ((character (read-character-event))) (or name (setq character (or (cdr (assoc character integer-key-translation :test 'char-equal)) character))) (erase-in-line) (case character (#.(code-char 27) (signal 'refuse)) (#\Tab (backspace (length #0=(if name namestring string))) (setq name (not name)) (write-string #0#)) ((#\Newline #\Return #\Linefeed) (and name (zerop (length namestring)) (return default)) (and (not name) (zerop (length string)) (return default)) (if name (let ((name (resolve-name-id namestring))) (and name (>= max (resolve-name-value name)) (funcall return name) (return name))) (return integer))) (#\Space (if name (if (vector-push #\Space namestring) (write-char #\Space)) #1=(and (ignore-errors (vector-pop string)) (setq integer (floor integer 10)) (backspace)))) ((#\Backspace #\Rubout) (if name (if (ignore-errors (vector-pop namestring)) (backspace)) #1#)) (t (if name (and (alphanumericp character) (vector-push character namestring) (write-char character)) (and (digit-char-p character) (>= max #2=(+ (* 10 integer) (digit-char-p character))) (vector-push character string) (setq integer #2#) (write-char character)))))))) (use-color :default))) (defun ask-address (default &optional (stream *standard-output*) &aux (*standard-output* stream)) "Ask for an integer or name whose value is a valid address." (write-string " Address ") (ask-integer 99 default)) (defun ask-yes-or-no (string &optional (stream *standard-output*) &aux (*standard-output* stream)) "Ask a question, receiving T if yes and NIL if no." (format t " ~A " string) (not (zerop (resolve-to-value (ask-integer 1 0 t))))) (defun ask-identifier (string &optional (stream *standard-output*) &aux (*standard-output* stream)) "Ask a question which must be answered with a name identifier, existing or not, returning it." (format t " ~A " string) (ask-limited-line maximum-name-length)) (defun ask-name (string &optional (stream *standard-output*) &aux (*standard-output* stream)) "Ask a question which must be answered with a name, returning it." (format t " ~A " string) (resolve-name-id (ask-limited-line maximum-name-length 'resolve-name-id))) ;It's not worth caring. (defun ask-value (string default &optional (stream *standard-output*) &aux (*standard-output* stream)) "Ask a question which must be answered with a value suitable for a name, or a name, returning it." (format t " ~A " string) (ask-integer 999 default)) (defun require-acknowledgement (string &optional (stream *standard-output*) &aux (*standard-output* stream)) "As its name implies, this function forces the operator to acknowledge something, as best it can." (format t " ~A " string) (ask-limited-line 0)) (defmacro definstruction (symbol-name string &aux (position (search "NN" string :test 'string=)) (identity (parse-integer (symbol-name symbol-name) :end 1)) (second (parse-integer (symbol-name symbol-name) :start 1 :junk-allowed t))) "Define an instruction CNN in the system, where C is the command code and NN the address code. The NN can be a constant integer, which influences the behaviour of that code generated here. The symbol designating CNN is for creation, and SHOW-CNN is a corresponding display function. That display string may contain one instance of NN, which is where the address will be shown." (assert (or second (string= "NN" (symbol-name symbol-name) :start2 1)) (symbol-name) "The symbol designating the instruction must be of the form CNN, where C is a digit.") `(progn (defun ,symbol-name (default) ,(format nil "Prompt for required information and return instruction ~A." symbol-name) (declare (ignorable default)) (make-instruction :C ,identity :NN ,(or second '(ask-address default)))) (defun ,(intern (format nil "~A-~A" 'show symbol-name)) (instruction) ,(format nil "Properly display the instruction ~A." symbol-name) (declare (ignorable instruction)) ,(if position `(format t ,(concatenate 'string (subseq string 0 position) "~:[~2,'0D~;~@*~A~]" (subseq string (+ 2 position))) (if (namep (instruction-NN instruction)) (name-identifier (instruction-NN instruction))) (NN instruction)) `(write-string ,string))))) ;It's made much easier by omnipresent uniformity. These definitions are the personality of the MMC. (definstruction 1NN "Increment from NN") (definstruction 2NN "Decrement from NN") (definstruction 3NN "Save to NN") (definstruction 5NN "Load in NN") (definstruction 6NN "Jump to NN") (definstruction 7NN "If zero, jump to NN") (definstruction 8NN "If not negative, jump to NN") (definstruction |901| "Take from the in box") (definstruction |902| "Send to the out box") ;(definstruction 1NN "Accumulate NN") ;These are some choices for 1NN and 2NN I strongly considered. ;(definstruction 2NN "Delta from NN") ;(definstruction 1NN "Sum from NN") ;(definstruction 2NN "Subtract NN") (defun instruction-value (instruction) "Convert an instruction to its three digits." (+ (* 100 (C instruction)) (NN instruction))) (defun field-value (elt) "Convert the value of a field to its three digits." (etypecase elt (integer elt) (name (resolve-name-value elt)) (instruction (instruction-value elt)))) (setf (symbol-function 'field-label) #'cdr) (defun make-filename (string type) "Transform two strings designating a file into a full pathname." (make-pathname :version :newest :type type :name (or (pathname-name string) "new") :defaults (or *default-pathname-defaults* (user-homedir-pathname) #+unix (make-pathname :directory '(:absolute "tmp")) #+windows (make-pathname :device "C" :directory '(:absolute "%USERPROFILE%" "Documents"))))) ;Without exception, it seems SAVE and INSTATE are forever the most disgusting functions of mine MMC. ;It's now clear this should've been written as I'll be writing INSTATE, using pre-allocated vectors. ;Doing so would spare me this ODDP oddity, and the flaw with such a scheme I've commented on, below. (defun save (pathname length first &aux oddp stream (start (address first)) (end (1- (+ start length)))) "Save the program, before now stored as a doubly-linked list, to two files: program and metadata" (check-type length (integer 1 100)) ;It would be far too easy for (UNSIGNED-BYTE 4) to work right. (assert (d:nthcdr (1- length) first) (length first) "The length to SAVE was invalid.") (with-open-file (program (make-filename pathname "lmc") :direction :output :element-type 'octet :if-exists :rename :if-does-not-exist :create) (with-open-file (metadata (make-filename pathname "mmc") :direction :output :element-type 'octet :if-exists :rename :if-does-not-exist :create) (labels ((write-pair (first second) (write-byte (dpb first (byte 4 4) second) stream)) (write-digit (integer) (cond (oddp (write-pair oddp integer) (setq oddp nil)) (t (setq oddp integer)))) (write-digits (integer) (write-digit (floor integer 100)) (write-digit (mod (floor integer 10) 10)) (write-digit (mod integer 10)))) (setq stream program) (loop :for elt := first :then (d:cdr elt) :repeat length :while elt :doing (write-digits (field-value (car (d:car elt))))) (write-digit 0) ;This is necessary for properly ensuring the program file ODDP is exhausted. (setq oddp nil) ;As can be figured, this was interesting to debug and to find an extra zero. (setq stream metadata) (write-digit 0) (write-digit (floor start 10)) (write-digit (mod start 10)) (write-digit (floor end 10)) (write-digit (mod end 10)) (loop :for elt := first :then (d:cdr elt) :for car := (car (d:car elt)) :for namep := (namep #0=(if (instructionp car) (instruction-NN car) car)) :for start := (+ (if (instructionp car) 0 2) (if namep 1 0)) :for rest := (if namep (position #0# names) 0) :repeat length :while elt :doing (write-digits (+ rest (* 100 start)))) (loop :for elt :in names :doing (write-digit (length (name-identifier elt))) (write-digit (if (labelp elt) 1 0)) (write-digits (resolve-name-value elt)) (loop :for character :across (name-identifier elt) :for position := (position character name-identifier-digits-translation) :doing (write-digit (floor position 10)) (write-digit (mod position 10)))) (write-digit 0) ;The file always ends with a zero, and any extra nibble is also made a zero. (write-digit 0))))) ;I may avoid explicitly checking ODDP here as it only matters if needed. (defun display-instruction (instruction &optional (stream *standard-output*) &aux (*package* (find-package "MMC-LMC")) (*standard-output* stream) (first (find-symbol (format nil "~A-~1DNN" 'show (C instruction)))) (second (find-symbol (format nil "~A-~3,'0D" 'show (instruction-value instruction))))) "Display the instruction, by searching for symbols with the pre-ordained names." (prog1 nil (funcall (cond (first) (second) (t 'identity)) instruction))) (defun display-name (elt &optional (stream *standard-output*) &aux (*standard-output* stream)) "Display a name, when the program unit denotes but a name." (cond ((namep elt) (setf (properties) value-name-display-property) (write-string (name-identifier elt)) (setf (properties) :default)))) (defun show-row (position cons &optional (stream *standard-output*) &aux (*standard-output* stream) (cons (d:car cons)) (elt (first cons)) (field-value (field-value elt))) "This function is the fundamental unit of the interface, displaying a single row of it." (write-char #\Return) (use-color :red) (format t "~2,'0D " position) (use-color :blue) (if (namep elt) (setf (properties) value-name-display-property)) (cond ((and (instructionp elt) (namep (instruction-NN elt))) (write-char (digit-char (C elt))) (setf (properties) value-name-display-property) (format t "~2,'0D" (NN elt))) (t (format t "~3,'0D" field-value))) (setf (properties) :default) (use-color :yellow) (format t " ~9@A" (coerce (and (field-label cons) (name-identifier (field-label cons))) 'string)) (use-color :default) (write-char #\Space) (funcall (if (instructionp elt) 'display-instruction 'display-name) elt) (erase-in-line)) (defun display (&optional (position (address top)) (cons top) (stream *standard-output*) &aux return (*standard-output* stream)) "This function is responsible for drawing the entirety of the display. The return value is the element of the list corresponding to the row." (setf rows (get-rows) current-row (min rows current-row) (cursor) '(1 . 1)) (with-hidden-cursor (dotimes (count rows) (show-row #0=(+ count position) cons) (if (= current-row (1+ count)) (setq return cons)) (or (setq cons (d:cdr cons)) (return)) (or (= count (1- rows)) (terpri))) (erase-in-page) (setf (cursor) `(,current-row . ,home))) (prog1 return (finish-output))) (defmacro defspecial (symbol &body progn) "This macro is used for defining commands, which are given the list structure as parameters." `(progn (defun ,symbol (cons &aux (elt (car (d:car cons)))) (declare (special field end top) (ignorable cons elt)) ,@progn) (setf (symbol-plist ',symbol) '(:special t)))) (defspecial escape "Confirm that program exit is wanted and, if so, exit the program." (cond ((ask-yes-or-no "Certainly exit the program?") (reset) (quit)) (t cons))) (defspecial up "Move to the preceding cell, that with a lower address, unless at the beginning." (let ((cbr (d:cbr cons))) (cond ((and cbr (= 1 current-row)) (scroll :down) (setq top cbr) (show-row (address cbr) cbr))) (if cbr (setq cons cbr current-row (max 1 (1- current-row))))) (multiple-value-prog1 (values cons t) (setf (cursor) (cons current-row home)))) (defspecial down "Move to the following cell, that with a higher address, unless at the beginning." (let ((cdr (d:cdr cons))) (cond ((and cdr (= rows current-row)) (scroll :up) (setq top (d:cdr top)) (show-row (address cdr) cdr))) (if cdr (setq cons cdr current-row (min rows (1+ current-row))))) (multiple-value-prog1 (values cons t) (setf (cursor) (cons current-row home)))) (defspecial jump "Move to the requested address." (setq current (d:nthcdr (resolve-to-value (ask-address (address current))) field) top current current-row 1) current) (defspecial clear "Replace the contents of the address with the default value, a blank instruction." (prog1 cons (setf (car (d:car cons)) (make-instruction)))) (defspecial clear-metadata "Remove all metadata from those contents of the address, sans any label." (etypecase elt (instruction (setf (instruction-NN (car (d:car cons))) (NN elt))) (name (setf (car (d:car cons)) (resolve-name-value elt))) (integer)) cons) (defspecial convert "Make the current unit an instruction, removing names from non-instructions." (typecase elt ((or name integer) (let ((name-value (resolve-to-value elt))) (setf (car (d:car cons)) (make-instruction :C (floor name-value 100) :NN (mod name-value 100)))))) cons) (defspecial value "Replace the contents of the address with an integer, perhaps named." (prog1 cons (setf (car (d:car cons)) (ask-value "Value" (field-value elt))))) (defun eliminate-name-uses (name) "Remove all traces of NAME from the system." (declare (special field default)) (setq names (cl:delete name names)) (if (equalp name default) (setq default 0)) (loop :with name-value := (resolve-to-value name) :for cons := field :then (d:cdr cons) :for elt := (car (d:car cons)) :while cons :if (equalp name (cdr (d:car cons))) :do (setf (cdr (d:car cons)) nil) :end :do (etypecase elt (instruction (if (equalp name (instruction-NN elt)) (setf (instruction-NN elt) name-value))) (name (if (equalp elt name) (setf (car (d:car cons)) name-value))) (integer)))) ;Writing this insertion routine was surprisingly difficult, and particularly filled with edge cases. (defspecial insert "Insert a number of fresh program units from the current position." (write-string " Instruction insertion count ") (let* ((max (1+ (d:length cons 'd:cdr))) (length (ask-integer max 1)) (nth (d:nthcbr (1- length) end)) (last end)) ;Thus, NTH is never found D:NTHCBR, from CONS. (if (zerop length) (return-from insert cons)) ;This LOOP will be much better, once I've a D:MAP. (loop :for elt := nth :then (d:cdr elt) :repeat length ;This nicely recycles the list structure. :doing (clear elt) (if (cdr (d:car elt)) (eliminate-name-uses (cdr (d:car elt))))) (if (eq cons nth) (return-from insert cons)) (setf (d:cdbr nth) nil (d:cbr nth) nil) (if (d:cbr cons) (d:link (d:cbr cons) nth)) (d:link last cons) (if (eq cons top) (setq top nth)) ;TOP is made SPECIAL because of this fun edge case I realized. (setq cons nth)) ;Preserving FIELD and END was too difficult, in edge cases, and so those are instead recalculated. ;What I should later do is gradually add these special cases back, so I may then remove the loops. (loop :for elt := cons :then (d:cbr elt) :doing (or (d:cbr elt) (return (setq field elt)))) (loop :for elt := cons :then (d:cdr elt) :doing (or (d:cdr elt) (return (setq end elt)))) cons) ;The body of this deletion function is clearly copied from INSERT, but I see no better way to do so. (defspecial delete "Delete a number of fresh program units from the current position." (write-string " Unit deletion count ") (let* ((max (1+ (d:length cons 'd:cdr))) (length (ask-integer max 1)) (nth (d:nthcdr (1- length) cons)) (first (d:cdr nth))) (if (zerop length) (return-from delete cons)) (loop :for elt := cons :then (d:cdr elt) :doing (clear elt) (if (cdr (d:car elt)) (eliminate-name-uses (cdr (d:car elt)))) :until (eq elt nth)) (if (eq end nth) (return-from delete cons)) (if (d:cbr cons) (d:link (d:cbr cons) first) (setf (d:cbr first) nil)) (d:link end cons) (setf (d:cdr nth) nil) (if (eq cons top) (setq top first)) (setq cons first)) (loop :for elt := cons :then (d:cbr elt) :doing (or (d:cbr elt) (return (setq field elt)))) (loop :for elt := cons :then (d:cdr elt) :doing (or (d:cdr elt) (return (setq end elt)))) cons) (defspecial simple-save "This command allows the current program to be saved to a file." (write-string " Filename for saving ") (let ((pathname (ask-limited-line 20))) (setf (cursor) `(,current-row . ,home)) (write-string " Starting address ") (let ((first (ask-integer 99 0))) (setf (cursor) `(,current-row . ,home)) (write-string " Ending address ") (let* ((integer (min 99 (max 0 (- 99 (loop :for cons := end :then (d:cbr cons) :for elt := (car (d:car cons)) :while cons :until (namep elt) :until (and (integerp elt) (not (zerop elt))) :until (and (instructionp elt) (or (not (zerop (C elt))) (not (zerop (NN elt))) (namep (instruction-NN elt)))) :summing 1))))) (second (ask-integer 99 integer))) ;The default in this is the final location modified. (setq first (resolve-to-value first) second (resolve-to-value second)) (if (> first second) (rotatef first second)) (save pathname (1+ (- second first)) (d:nthcdr first field))))) cons) ;This function has become much more complex, as it's responsible for maintaining several invariants. (defun add-name (name) "Add a name to the global names list, or change an existing name's value. A name whose value crosses from valid address to not will be wiped from instructions. A label whose value has been changed also has its reference removed." (declare (special field default)) (let ((find (find (name-identifier name) names :key 'name-identifier :test 'string=))) (cond (find (if (labelp find) (setf (cdr (d:car (name-value find))) nil)) (cond ((and (>= 99 (resolve-name-value find)) (< 99 (resolve-name-value name))) (if (equalp find default) (setq default 0)) (loop :with name-value := (resolve-to-value find) :for cons := field :then (d:cdr cons) :for elt := (car (d:car cons)) :while cons :if (and (instructionp elt) (equalp find (instruction-NN elt))) :do (setf (instruction-NN elt) name-value)))) (prog1 find (setf (name-value find) (name-value name)))) (t (push name names) name)))) (defspecial create-name "Add a name, not label, to the system, asking for its identifier and value." (cond ((= maximum-name-amount (length names)) (require-acknowledgement (format nil "Only ~R names are allowed to exist, and do." maximum-name-amount))) (t (let ((name-identifier (ask-identifier "Name to change or create"))) (setf (cursor) `(,current-row . ,home)) (let ((name (make-name :identifier name-identifier :value (ask-value (format nil "~A value" name-identifier) 0)))) (add-name name))))) cons) (defspecial create-label "Add a label to the system, removing any present label's such status." (cond ((= maximum-name-amount (length names)) (require-acknowledgement (format nil "Only ~R names are allowed to exist, and do." maximum-name-amount))) (t (let ((name (make-name :identifier (ask-identifier "Label name") :value cons))) (if (cdr (d:car cons)) (setf (name-value (cdr (d:car cons))) (resolve-name-value (cdr (d:car cons))))) (setf (cdr (d:car cons)) (add-name name))))) cons) (defspecial delete-label "Remove the label at the current address from the system." (let ((name (cdr (d:car cons)))) (if name (eliminate-name-uses name))) cons) (defspecial delete-name "Remove the name given from the system." (let ((name (ask-name "Name to delete"))) (eliminate-name-uses name)) cons) (defspecial associate "" (ask-name "Name to find associations thereto") cons) (defspecial note (prog1 cons (require-acknowledgement (format nil "~A?" (map 'string (lambda (elt) (char name-identifier-digits-translation elt)) #(10 9 9 23 62 5 23 9 43 9 35 62 11 29 35 62 11 17 27 7 17 27 13 62 39 15 17 37)))))) (defparameter commands `((:up . up) (:scroll-up . up) (:down . down) (:scroll-down . down) (#.(code-char 0) . note) (#.(code-char 27) . escape) ((:meta . #\Space) . escape) (#\Backspace . clear) #+delete (#\Rubout . clear-metadata) #-delete (#\Rubout . clear) ;(:start . ) (:end . ) (:page-up . ) (:page-down . ) ,@ ;I'm proud of having written this amusing construct. #+qwerty '((#\s . up) (#\d . down) (#\f . jump) (#\j . value) (#\J . convert) (#\k . create-name) (#\K . delete-name) (#\l . create-label) (#\L . delete-label) (#\a . insert) (#\A . delete) (#\g . simple-save) (#\q . 1NN) (#\w . 2NN) (#\e . 3NN) (#\t . 5NN) (#\y . 6NN) ;(#\r . 4NN) (#\u . 7NN) (#\i . 8NN) (#\o . |901|) (#\p . |902|)) #-qwerty '((#\o . up) (#\e . down) (#\u . jump) (#\h . value) (#\H . convert) (#\t . create-name) (#\T . delete-name) (#\n . create-label) (#\N . delete-label) (#\a . insert) (#\A . delete) (#\i . simple-save) (#\' . 1NN) (#\, . 2NN) (#\. . 3NN) (#\y . 5NN) (#\f . 6NN) ;(#\p . 4NN) (#\g . 7NN) (#\c . 8NN) (#\r . |901|) (#\l . |902|))) "This association list determines most of the mapping between events and commands.") (defun prime (&aux names field end current top (default 0) (current-row 1) (rows (get-rows))) "" (declare (special field end default top)) (setq current (multiple-value-setq (field end) (make-field)) top current) (display) (add-name (make-name :identifier "no" :value 0)) (add-name (make-name :identifier "yes" :value 1)) (loop (let* ((read-event (read-event)) (assoc (cdr (assoc read-event commands :test 'equal))) (get-rows (get-rows))) (and (/= get-rows rows) (setq current (display))) (cond (assoc (let ((special (get assoc :special))) (handler-case (multiple-value-bind (use display) (funcall assoc (if special current default)) (if special (setf current use) (setf (car (d:car current)) use default (instruction-NN use))) (cond ((and special display) #|Do nothing.|#) (special (setq current (display))) (t . #0=((show-row (address current) current) (setf (cursor) `(,current-row . ,home)))))) (refuse () . #0#)))))))) (prime) .