;MMC-CHIP-8 - A Meta-Machine Code targeted at CHIP-8.
;Copyright 2017,2018 Prince Trippy programmer@verisimilitudes.net .

;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 <http://www.gnu.org/licenses/>.

(cl:defpackage #:mmc-chip-8
  (:documentation "The MMC is a metaprogrammable machine code development environment named after its Meta-Machine Code.")
  (:use #:common-lisp #:shut-it-down #:acute-terminal-control)
  (:import-from #:cl-ecma-48 #:cursor-character-absolute #:line-feed #:erase-in-line #|#:character-position-backward|#)
  (:export #:mmc-chip-8))

(cl:in-package #:mmc-chip-8)

;The quality of this code is rather poor, considering how many times it has been partially or almost entirely rewritten.
;The evolving dynamics of the MMC and tight integration with Meta-CHIP-8 don't help, but were important to reach this point.
;Put simply, it was integrated poorly in an earlier version, so I ensured the opposite problem later on.
;I'd like to write this will eventually be rewritten, now that the requirements are concrete, but it likely won't be.
;I'll likely play with implementing an MMC targeted at CHIP-8 without Meta-CHIP-8 in another language, instead.
;Regardless, it's around one thousand lines, so it's not nearly so much of a mess as I imply.

(defparameter field (make-array (expt 2 12) :element-type '(unsigned-byte 8) :initial-element 0)
  "The array containing the CHIP-8 program space.")

(defparameter meta-field (make-array (expt 2 12) :element-type '(unsigned-byte 8) :initial-element 0)
  "The array containing the Meta-CHIP-8 program space.")

(defparameter ranges (make-array (expt 2 12) :element-type 'boolean
                                 :initial-contents (loop for i = t then (not i) repeat (expt 2 12) collecting i))
  "The array containing the CHIP-8 range data, which indicates beginnings and encompassings.")

;(defparameter metadata (make-array `(,(expt 2 12) 3) :element-type '(unsigned-byte 12) :initial-element 0)
;  "The array containing the rest of the CHIP-8 program metadata, subarrays stored as #(routine arrangement name).")

(defparameter routines (make-array (expt 2 12) :element-type '(unsigned-byte 12) :initial-element 0)
  "The array containing the CHIP-8 routine association metadata.")

(defparameter name-assoc (make-array (expt 2 12) :element-type '(unsigned-byte 3) :initial-element 0)
  "The array containing the CHIP-8 name association metadata metadata.")

(defparameter name-table (make-array (expt 2 12) :element-type '(unsigned-byte 12) :initial-element 0)
  "The array containing the CHIP-8 name association metadata.")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter names (make-array (expt 2 12) :element-type '(or null cons) :initial-element nil)
    "The storage for all symbolic names registered, represented as NIL or (labelp name . value).")
  (setf (aref names 0) (list* nil "" 0))
  ;(setf (aref names 1) (list* nil "yes" 1))
  ;(setf (aref names 2) (list* nil "no" 0))
  ;(setf (aref names 3) (list* t "start" 512))
  )

;(defparameter labels (make-array (expt 2 12) :element-type '(unsigned-byte 12) :initial-element 0)
;  "The fast storage used for all symbolic names assigned to program addresses.")

;(setf (aref labels 512) 3)

(defparameter latest-name 0
  "The last name code to be used in an integral ask and also the length of the answer to a character ask.  This is a kludge.")

(defparameter character-set
  (concatenate 'string
               "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz "
               "█↑→↓←:;,.?!−÷+×=<>()[]`'∞                                        "
               "                                                                "
               "                                                                ")
  "This is the character set of Meta-Machine Code targeted towards CHIP-8; currently undefined characters are spaces.")

(defvar rows (first (dimensions))
  "This is the number of rows the program knows it can use.")

(defparameter home 62
  "The home column position.")

(defparameter show-home (1+ home)
  "The beginning position for a show.  This is a kludge.")

(defparameter current-row 1
  "This is the current display row.")

(defparameter current-address #x200
  "This is the current address to display.")

(defparameter top-address #x200
  "This is the address for the top of the display, used for redisplay.")

(defparameter ghost-answer nil
  "This is the default answer, shown when being asked, if not NIL.
This is a global value, due to complications otherwise.
This is a kludge.")

(defparameter use-color t
  "This determines whether the interface will use color codes or not.
It is set to NIL before the main loop, if a ``.mmc-no-color'' file exists in the user home directory.
This is a kludge of sorts.")

(defparameter zero-character #\0
  "This is the character that will be used to display a zero when showing binary.
It is set to the first character from the ``.mmc-binary-characters'' before the main loop, if the file exists in the user home directory.
This is a kludge of sorts.")

(defparameter one-character #\1
  "This is the character that will be used to display a one when showing binary.
It is set to the second character from the ``.mmc-binary-characters'' before the main loop, if the file exists in the user home directory.
This is a kludge of sorts.")

(defparameter redraw-row t
  "This indicates whether the current row should be redrawn or not, as an optimization primarily intended for the up and down movements.
This is a kludge of sorts.")

(defparameter modified-addresses nil
  "This is a list of field addresses modified by an operation, used for dedisplay.
This is a kludge and very inefficient, but also easier to implement at such a late point.")

(defparameter redisplay-needed nil
  "This indicates whether the new display algorithm conditions have been triggered and a full redisplay is necessary to maintain consistency.
This is, unfortunately, a kludge of sorts.")

(defparameter show-as-stacked nil
  "This indicates whether SHOW-ROW should should display bytes as stacked or as normal binary numbers.
The ZERO-CHARACTER and ONE-CHARACTER are ignored when this is T.
This is something of a kludge, but not terrible.")

;Center.
;Move display to new address.
;Move down.
;Move up.
;Save.
;Add contents of a file.
;Enter a number at the current address.
;Make a new name.
;Name the current address.
;Remove a name.

;Reset memory address.
;Clear metadata.
;Exit.

(defun fronttrack (&optional (address current-address))
  ""
  (let ((f (if (/= #xFFF address) (position t (subseq ranges (1+ address)))))
        (b (position t ranges :end (min (1+ address) #xFFF))))
    (cond (f (+ address (1+ f)))
          (b)
          (t #x200)))) ;This shouldn't be reached, but oh well.

(defun backtrack (&optional (address current-address))
  ""
  (let ((f (if (/= #xFFF address) (position t (subseq ranges (1+ address)) :from-end t)))
        (b (position t ranges :end address :from-end t)))
    (cond (b)
          (f (+ address (1+ f)))
          (t #x200)))) ;This also shouldn't be reached, but oh well.

(defun cleanse (address)
  ""
  (setf (aref routines address) 0
        (aref name-assoc address) 0
        (aref name-table address) 0
        (aref ranges address) t))

(defun save (start end compressed)
  (declare (ignore compressed))
;  (with-open-file (*standard-output* (make-pathname :name "check" :defaults (user-homedir-pathname))
;                                     :direction :output :if-exists :supersede :if-does-not-exist :create)
;    (print names)
;    (print labels))
  (if (> start end)
      (psetq start end end start))
  (handler-case
      (let* ((answer (progn (cursor-character-absolute show-home) (show "Filename to save ") (ask :length 128 nil t)))
             (pathname-defaults
              (make-pathname :name (if answer (pathname-name answer) "default")
                             :directory (if answer (pathname-directory answer))
                             :defaults
                             (or *default-pathname-defaults*
                                 (user-homedir-pathname)
                                 #+unix (make-pathname :directory '(:absolute "tmp"))
                                 #+windows (make-pathname :device "C"
                                                          :directory '(:absolute "%USERPROFILE%" "Documents")))))
             (chip8 (make-pathname :type "chip8" :defaults pathname-defaults))
             (chip8-backup (make-pathname :type "chip8b" :defaults chip8))
             (meta (make-pathname :type "mmc" :defaults pathname-defaults))
             (meta-backup (make-pathname :type "mmcb" :defaults meta)))
        (if (probe-file chip8)
            (progn (if (probe-file chip8-backup)
                       (delete-file chip8-backup))
                   (rename-file chip8 chip8-backup)))
        (with-open-file (file chip8 :direction :output :element-type '(unsigned-byte 8)
                              :if-exists :supersede :if-does-not-exist :create)
          (write-sequence field file :start start :end (1+ end))
          (finish-output file))
        (if (probe-file meta)
            (progn (if (probe-file meta-backup)
                       (delete-file meta-backup))
                   (rename-file meta meta-backup)))
        (with-open-file (file meta :direction :output :element-type '(unsigned-byte 8)
                              :if-exists :supersede :if-does-not-exist :create)
          (write-byte 0 file)
          (write-byte 0 file)
          (write-byte (ldb (byte 4 8) start) file)
          (write-byte (ldb (byte 8 0) start) file)
          (write-byte (ldb (byte 4 8) end) file)
          (write-byte (ldb (byte 8 0) end) file)
          (cond ((or (= start end) (oddp (- (1+ end) start)))
                 (loop for i from start below end by 2 for j = (1+ i)
                       for e = (dpb (if (aref ranges i) 1 0) (byte 1 27)
                                    (dpb (aref name-assoc i) (byte 3 24)
                                         (dpb (aref routines i) (byte 12 12)
                                              (aref name-table i))))
                       for f = (dpb (if (aref ranges j) 1 0) (byte 1 27)
                                    (dpb (aref name-assoc j) (byte 3 24)
                                         (dpb (aref routines j) (byte 12 12)
                                              (aref name-table j))))
                       do (write-byte (ldb (byte 8 20) e) file)
                          (write-byte (ldb (byte 8 12) e) file)
                          (write-byte (ldb (byte 8 4) e) file)
                          (write-byte (dpb (ldb (byte 4 0) e) (byte 4 4)
                                           (ldb (byte 4 24) f))
                                      file)
                          (write-byte (ldb (byte 8 16) f) file)
                          (write-byte (ldb (byte 8 8) f) file)
                          (write-byte (ldb (byte 8 0) f) file))
                 (let ((e (dpb (if (aref ranges end) 1 0) (byte 1 27)
                               (dpb (aref name-assoc end) (byte 3 24)
                                    (dpb (aref routines end) (byte 12 12)
                                         (aref name-table end))))))
                   (write-byte (ldb (byte 8 20) e) file)
                   (write-byte (ldb (byte 8 12) e) file)
                   (write-byte (ldb (byte 8 4) e) file)
                   (write-byte (dpb (ldb (byte 4 0) e) (byte 4 4) 0) file)))
                (t (loop for i from start below (1+ end) by 2 for j = (1+ i)
                         for e = (dpb (if (aref ranges i) 1 0) (byte 1 27)
                                      (dpb (aref name-assoc i) (byte 3 24)
                                           (dpb (aref routines i) (byte 12 12)
                                                (aref name-table i))))
                         for f = (dpb (if (aref ranges j) 1 0) (byte 1 27)
                                      (dpb (aref name-assoc j) (byte 3 24)
                                           (dpb (aref routines j) (byte 12 12)
                                                (aref name-table j))))
                         do (write-byte (ldb (byte 8 20) e) file)
                            (write-byte (ldb (byte 8 12) e) file)
                            (write-byte (ldb (byte 8 4) e) file)
                            (write-byte (dpb (ldb (byte 4 0) e) (byte 4 4)
                                             (ldb (byte 4 24) f))
                                        file)
                            (write-byte (ldb (byte 8 16) f) file)
                            (write-byte (ldb (byte 8 8) f) file)
                            (write-byte (ldb (byte 8 0) f) file))))
          (loop for (label name . value) across (subseq names 1)
                until (null name)
                doing (write-byte (ldb (byte 8 8) value) file)
                      (write-byte (ldb (byte 8 0) value) file)
                      (write-byte (dpb (if label 1 0) (byte 1 4)
                                       (ldb (byte 4 0) (length name)))
                                  file)
                      (write-sequence (map 'vector (lambda (c) (position c character-set)) name)
                                      file))
          (finish-output)))
    (error ()
      (cursor-character-absolute show-home)
      (show "The save failed.")
      (ask :length 0)))
  (values))

(let ((buffer (make-array (* 7 (/ (expt 2 12) 2)) :element-type '(unsigned-byte 8) :initial-element 0))
      (new-names (make-array (expt 2 12) :element-type '(or null cons) :initial-element nil))
      ;(new-labels (make-array (expt 2 12) :element-type '(unsigned-byte 12) :initial-element 0))
      )
  (defun instate () ;How fragile oh how fragile.
    (setq new-ranges (copy-seq ranges))
    (handler-case (let* ((answer (progn (cursor-character-absolute show-home) (show "Filename to instate ") (ask :length 128 nil t)))
                         (pathname-defaults (make-pathname :name (if answer (pathname-name answer) "default")
                                                           :directory (if answer (pathname-directory answer))
                                                           :defaults
                                                           (or *default-pathname-defaults*
                                                               (user-homedir-pathname)
                                                               #+unix (make-pathname :directory '(:absolute "tmp"))
                                                               #+windows (make-pathname :device "C"
                                                                                        :directory '(:absolute "%USERPROFILE%" "Documents")))))
                         (chip8 (make-pathname :type "chip8" :defaults pathname-defaults))
                         (meta (make-pathname :type "mmc" :defaults pathname-defaults))
                         start end s e cleanse)
                    (assert (or (probe-file chip8) (probe-file meta)))
                    (with-open-file (file meta :direction :input :element-type '(unsigned-byte 8) :if-does-not-exist nil)
                      (or file (setq cleanse t))
                      (cond (file (assert (zerop (read-byte file)))
                                  (assert (zerop (read-byte file)))
                                  (setq s (dpb (read-byte file) (byte 4 8) (read-byte file))
                                        e (dpb (read-byte file) (byte 4 8) (read-byte file)))
                                  (if (> s e)
                                      (psetq s e e s))
                                  (assert (= (ceiling (* 3.5 (- (1+ e) s)))
                                             (read-sequence buffer file :end (ceiling (* 3.5 (- (1+ e) s))))))
                                  (prog (first second third length label value (count 1) (name-buffer (make-array 15))) :begin
                                        (setq first (read-byte file nil)
                                              second (read-byte file nil)
                                              third (read-byte file nil))
                                        (unless (and first second third) (go :end))
                                        (setq length (ldb (byte 4 0) third))
                                        (assert (= length (read-sequence name-buffer file :end length)))
                                        (assert (not (zerop length)))
                                        (setf label (not (zerop (ldb (byte 1 4) third)))
                                              value (dpb first (byte 8 8) second)
                                              (aref new-names count) (list* label
                                                                            (map 'string (lambda (c) (char character-set c))
                                                                                 (subseq name-buffer 0 length))
                                                                            value))
                                        ;(if label (setf (aref new-labels value) count))
                                        (incf count)
                                        (go :begin)
                                        :end
                                        (setf (aref new-names 0) (list* nil "" 0)))
                                  (loop for n from 0
                                        for i from s to e
                                        for j = (floor (* 3.5 n))
                                        for k = (evenp n)
                                        for first = (aref buffer j)
                                        for second = (aref buffer (1+ j))
                                        for third = (aref buffer (+ 2 j))
                                        for fourth = (aref buffer (+ 3 j))
                                        doing (if k
                                                  (setf (aref ranges i) (not (zerop (ldb (byte 1 7) first)))
                                                        (aref name-assoc i) (ldb (byte 3 4) first)
                                                        (aref routines i) (dpb (ldb (byte 4 0) first) (byte 4 8) second)
                                                        (aref name-table i) (dpb third (byte 8 4) (ldb (byte 4 4) fourth)))
                                                  (setf (aref ranges i) (not (zerop (ldb (byte 1 3) first)))
                                                        (aref name-assoc i) (ldb (byte 3 0) first)
                                                        (aref routines i) (dpb second (byte 8 4) (ldb (byte 4 4) third))
                                                        (aref name-table i) (dpb (ldb (byte 4 0) third) (byte 4 8) fourth))))
                                  (setq names (copy-seq new-names)
                                        ;labels new-labels
                                        )
                                  (setq start s end e))))
                    (with-open-file (file chip8 :direction :input :element-type '(unsigned-byte 8) :if-does-not-exist nil)
                      (if file
                          (let ((beginning (or start
                                               (if (> (file-length file) #xE00) #x000 #x200))))
                            (read-sequence field file :start beginning :end (if end (1+ end)))
                            (cond (cleanse (fill routines 0 :start beginning :end (if end (1+ end)))
                                           (fill name-assoc 0 :start beginning :end (if end (1+ end)))
                                           (fill name-table 0 :start beginning :end (if end (1+ end)))
                                           (fill ranges t :start beginning :end (if end (1+ end)))))))))
      (error ()
        (cursor-character-absolute show-home)
        (show "The instate failed.")
        (ask :length 0)))
    (redraw-display)
    (setq redraw-row nil)
    (values)))

(defun jump (address)
  (setq redraw-row nil)
  (setq current-row 1
        current-address address
        top-address current-address
        rows (or (first (dimensions)) rows))
  (redraw-display)
  (values))

(defun up ()
  (setq redraw-row nil)
  (if (= 1 current-row)
      (progn (scroll :down)
             (show-row (setq current-address (backtrack)))
             (setf (cursor) (cons 1 home)
                   top-address current-address))
      (setf current-row (1- current-row)
            (cursor) (cons current-row home)
            current-address (backtrack)))
  (values))

(defun down ()
  (setq redraw-row nil)
  (if (= rows current-row)
      (progn (scroll :up)
             (show-row (setq current-address (fronttrack)))
             (setf (cursor) (cons rows home)
                   top-address (fronttrack top-address)))
      (setf current-row (1+ current-row)
            (cursor) (cons current-row home)
            current-address (fronttrack)))
  (values))

(defun insert (length)
  "Insert fresh data beginning from CURRENT-ADDRESS."
  (if (zerop length) (return-from insert))
  (setq redisplay-needed t)
  (loop for a in '(field ranges routines name-assoc name-table)
        for b in '((unsigned-byte 8)
                   boolean
                   (unsigned-byte 12)
                   (unsigned-byte 3)
                   (unsigned-byte 12))
        do (set a (concatenate `(vector ,b 4096)
                               (subseq (symbol-value a) 0 current-address)
                               (if (eq b 'boolean)
                                   (loop for i = t then (not i) repeat length collecting i)
                                   (make-array length :element-type '(unsigned-byte 8) :initial-element 0))
                               (subseq (symbol-value a) current-address (- 4096 length)))))
  (loop for n across names while n
        do (and (car n)
                (<= current-address (cddr n))
                (if (> #x1000 (+ length (cddr n)))
                    (change-name (cadr n) (+ length (cddr n)) t)
                    (delete-name (name-position (cadr n)))))))

(defun shift (length)
  "Delete data beginning from CURRENT-ADDRESS, shifting in fresh data."
  (if (zerop length) (return-from shift))
  (setq redisplay-needed t)
  (loop for a in '(field ranges routines name-assoc name-table)
        for b in '((unsigned-byte 8)
                   boolean
                   (unsigned-byte 12)
                   (unsigned-byte 3)
                   (unsigned-byte 12))
        do (set a (concatenate `(vector ,b 4096)
                               (subseq (symbol-value a) 0 current-address)
                               (subseq (symbol-value a) (+ length current-address))
                               (if (eq b 'boolean)
                                   (loop for i = t then (not i) repeat length collecting i)
                                   (make-array length :element-type '(unsigned-byte 8) :initial-element 0)))))
  (loop for n across names while n
        do (and (car n)
                (<= current-address (cddr n))
                (if (<= current-address (- (cddr n) length))
                    (change-name (cadr n) (- (cddr n) length) t)
                    (delete-name (name-position (cadr n)))))))

(defun backspace (&optional (count 1) (stream *standard-output*) &aux (*standard-output* stream))
  "Move the cursor back by COUNT, leaving spaces at the previous locations, returning count."
  (dotimes (c count count) (declare (ignorable c)) (ecma-48:backspace) (write-char #\space) (ecma-48:backspace)))

(defun show-row (&optional (address current-address) (stream *standard-output*) &aux (*standard-output* stream))
  ""
  (cursor-character-absolute show-home)
  (erase-in-line)
  (let* ((o (fronttrack address)) ;There's a hack for everything.
         (c (meta-chip-8 address (aref routines address)))
         (v (cond ((= c 1) (aref field address))
                  ((= c 2) (dpb (aref field address) (byte 8 8) (aref field (mod (1+ address) #x1000))))
                  ((= c 3) (dpb (aref field address) (byte 8 16)
                                (dpb (aref field (mod (1+ address) #x1000)) (byte 8 8)
                                     (aref field (mod (+ 2 address) #x1000)))))
                  ((= c 4) (+ (ash (aref field address) 24)
                              (ash (aref field (mod (1+ address) #x1000)) 16)
                              (ash (aref field (mod (+ 2 address) #x1000)) 8)
                              (aref field (mod (+ 3 address) #x1000))))))
;         (ter (coerce (mapcar (lambda (d) (aref " ▐▌█" d)) (map 'list 'digit-char-p (format nil "~4r" v))) 'string))
         (end (if (< 1 c) (mod (+ address (1- c)) #x1000))))
    (if end
        (if (> address end)
            (progn (fill ranges nil :end end)
                   (fill ranges nil :end #x1000 :start address))
            (fill ranges nil :end end :start address)))
    (if end (setf (aref ranges end) nil))
    (setf (aref ranges address) t
          (aref ranges (mod (1+ (or end address)) #x1000)) t)
    (cursor-character-absolute)
    (and use-color (setf (foreground) :green))
    (format t "~3,'0x~:[    ~;~:*-~3,'0x~] " address end)
    (and use-color (setf (foreground) :red))
    (format t "~4,'0d~:[     ~;~:*-~4,'0d~] " address end)
    (and use-color (setf (foreground) :blue))
;    (write-string (case c
;                    (1 (format nil "~12@a ~2,'0x~:* ~3,'0d " ter v))
;                    (2 (format nil "~12@a ~4,'0x~:* ~5,'0d " ter v))
;                    (3 (format nil "~12@a ~6,'0x~:* ~8,'0d " ter v))
;                    (t "............ ...... ........ ")))
    (write-string (if show-as-stacked
                      (case c ;This path is horribly inefficient, but I don't care right now.
                        (1 (map 'string (lambda (c) (case c
                                                      (#\0 zero-character)
                                                      (#\1 one-character)
                                                      (t c)))
                                (format nil "~8,'0b" v)))
                        (2 (map 'string (lambda (c d)
                                          (cond ((char-equal #\0 c d) #\space)
                                                ((and (char-equal #\1 c) (char-equal #\0 d)) #\▀)
                                                ((and (char-equal #\0 c) (char-equal #\1 d)) #\▄)
                                                ((char-equal #\1 c d) #\█)))
                                (subseq (format nil "~16,'0b" v) 0 8)
                                (subseq (format nil "~16,'0b" v) 8))))
                      (map 'string (lambda (c) (case c
                                                 (#\0 zero-character)
                                                 (#\1 one-character)
                                                 (t c)))
                           (case c
                             (1 (format nil "        ~8,'0b" v))
                             (2 (format nil "~16,'0b" v))))))
    (write-string (case c
                    (1 (format nil "   ~2,'0x~:*   ~3,'0d " v))
                    (2 (format nil " ~4,'0x~:* ~5,'0d " v))
                    (3 (format nil "........... ~6,'0x~:* ~8,'0d " v))
                    (4 (format nil "....... ~8,'0x~:* ~10,'0d " v))
                    (t "................ .... ..... ")))
    (and use-color (setf (foreground) :yellow))
    (format t "~15@a" (coerce (loop for n across names while n
                                    if (and (car n) (= address (cddr n)))
                                       do (return (cadr n)))
                              'string))
    (and use-color (setf (properties) :default))
    (write-char #\space)
    (cursor-character-absolute home)
    (unless (<= o (fronttrack address)) ;Yes, there's a hack for everything.
      (setq redisplay-needed t))
    c))

(defun redraw-display (&optional (address top-address) (stream *standard-output*) &aux (*standard-output* stream))
  ""
  (erase)
  (setf (cursor) ())
  (setq rows (or (first (dimensions)) rows))
  (dotimes (r rows)
    (if (= (1+ r) current-row)
        (setf current-address address))
    (setq address (ldb (byte 12 0) (+ address (show-row address))))
    (if (/= (1+ r) rows)
        (line-feed)))
  (setf (cursor) (cons current-row home))
  (finish-output)
  (values))

(defun update-name (code)
  (declare (type (unsigned-byte 12) code))
  (if (zerop code) (return-from update-name))
  (loop for i from 0 to 4095
        doing (cond ((= code (aref name-table i))
                     (push i modified-addresses)
                     (case (aref name-assoc i)
                       (0)
                       (1 (setf (aref field i) (dpb (cddr (aref names code)) (byte 4 0) (aref field i))))
                       (2 (setf (aref field i) (dpb (cddr (aref names code)) (byte 4 4) (aref field i))))
                       ((3 4) (setf (aref field i) (ldb (byte 8 0) (cddr (aref names code)))))
                       ((5 6) (setf (aref field i) (dpb (ldb (byte 4 8) (cddr (aref names code))) (byte 4 0) (aref field i))
                                    (aref field (ldb (byte 12 0) (1+ i))) (ldb (byte 8 0) (cddr (aref names code)))))
                       (7 (setf (aref field i) (ldb (byte 8 8) (cddr (aref names code)))
                                (aref field (ldb (byte 12 0) (1+ i))) (ldb (byte 8 0) (cddr (aref names code))))))))))

(defun create-name (name value &optional label &aux (position (position nil names)))
  "Add a name with a value to the system, optionally as a label.
Any existing name is simply duplicated."
  (declare (type string name)
           (type (unsigned-byte 12) value)
           (type boolean label))
  (if (zerop (length name)) (return-from create-name 0))
  (unless position (return-from create-name 0))
  (setf (aref names position) (list* (and label (> #x1000 value)) name value))
  (and label (> #x1000 value)
       (progn ;(setf (aref labels value) position)
              (loop for i from 0 to 4095 for n = (aref names i)
                    while n
                    do (and (car n)
                            (= value (cddr n))
                            (string/= name (cadr n))
                            (setf (car n) nil)))
              (push value modified-addresses)))
  (update-name position)
  position)

(defun change-name (name value &optional label &aux (present (position name names :test 'string= :key 'cadr)))
  "Add a name with a value to the system, optionally as a label.
An existing name is modified."
  (declare (type string name)
           (type (unsigned-byte 12) value)
           (type boolean label))
  (if (zerop (length name)) (return-from change-name 0))
  (if present
      (progn (if (car (aref names present))
                 (progn ;(setf (aref labels (cddr (aref names present))) 0)
                        (push (cddr (aref names present)) modified-addresses)))
             (setf (aref names present) (list* (and label (> #x1000 value)) name value))
             ;(and label (> #x1000 value) (setf (aref labels value) present))
             (and label (> #x1000 value)
                  (loop for i from 0 to 4095 for n = (aref names i)
                        while n
                        do (and (car n)
                                (= value (cddr n))
                                (string/= name (cadr n))
                                (setf (car n) nil))))
             (update-name present)
             present)
      (create-name name value label)))

(defun find-name (name)
  ""
  (or (find name names :key 'cadr :test 'string=)
      (aref names 0)))

(defun find-label (address)
  ""
  (aref names (label-position address)))

(defun name-position (name)
  ""
  (or (position name names :key 'cadr :test 'string=) 0))

(defun label-position (address)
  (or (loop for i from 0 to 4095 for n = (aref names i)
            while n
            do (and (car n)
                    (= address (cddr n))
                    (return i)))
      0))

(defun delete-name (code)
  "Remove a name from the system."
  (declare (type (unsigned-byte 12) code))
  (if (zerop code) (return-from delete-name))
  (let ((name (aref names code)))
    (if (car name)
        (progn (push (cddr name) modified-addresses)
               ;(setf (aref labels (cddr name)) 0)
               )))
  (let* ((last (position-if-not 'null names :from-end t))
         (label (car (aref names last)))
         (value (cddr (aref names last))))
    (if (zerop last) (return-from delete-name))
    (setf (aref names code) (aref names last)
          (aref names last) nil)
    ;(if label (setf (aref labels value) code))
    (loop for i from 0 to 4095
          doing (if (= code (aref name-table i))
                    (push i modified-addresses)))
    (setq name-table (nsubstitute 0 code name-table))
    (loop for i from 0 to 4095
          doing (if (zerop (aref name-table i))
                    (setf (aref name-assoc i) 0)))
    (setq name-table (nsubstitute code last name-table))))

(defun read-limited-line (limit default &optional ignore-table)
  "Read in a line of a length determined by limit, inclusive, based on the textual ask input table.
The ignore-table argument is a kludge."
  (and use-color (setf (foreground) :magenta))
  (prog (v c (n 0) (escape (aref meta-field #xff0))
         (table (+ (ash (aref meta-field #xfee) 8) (aref meta-field #xfef)))) :begin
         (clear-input)
         (setq c (mod (char-code (read-char)) 128)
               c (if (= c escape)
                     (throw 'abort nil)
                     (if ignore-table
                         (case (code-char c)
                           ((#\newline #.(code-char 10) #.(code-char 13)) 255)
                           ((#.(code-char 8) #.(code-char 127)) 254)
                           (#.(code-char 9) 253)
                           (t (code-char c)))
                         (aref meta-field (+ table c))))
               c (case c
                   (255 :enter)
                   (254 :backspace)
                   (253 (go :begin))
                   (252 (throw 'abort nil))
                   (t (if ignore-table c
                          (aref character-set (mod c 128))))))
         (case c
           (:enter (go :finish))
           (:backspace (or (zerop n)
                           (progn (backspace)
                                  (setq n (1- n) v (cdr v)))))
           (t (if (> limit n)
                  (progn (write-char c)
                         (push c v)
                         (incf n)))))
         (finish-output)
         (go :begin)
         :finish
         (setq latest-name n) ;This is a kludge.
         (return (if (zerop n)
                     default
                     (make-array n :element-type 'character :initial-contents (reverse v))))))

(defun read-integer (limit default &optional start-in-name)
  "Read in an integer of a magnitude determined by limit, inclusive, based on the integral ask input table.
The start-in-name argument is a kludge."
  (if start-in-name (setq ghost-answer nil))
  (and ghost-answer
       ;(>= limit ghost-answer)
       (let ((*print-base* 10))
         (and use-color (setf (foreground) '(:rgb 128 128 128)))
         (princ ghost-answer)
         (loop repeat (length (princ-to-string ghost-answer)) do (ecma-48:backspace))))
  (finish-output)
  (and use-color (setf (foreground) :magenta))
  (setf latest-name 0)
  (prog (name c (n 0) (v 0) (base 10) (length 16) (escape (aref meta-field #xff0))
         (table (+ (ash (aref meta-field #xfec) 8) (aref meta-field #xfed))))
     (and start-in-name (setq c :name) (go :skip)) :begin
     (clear-input)
     (setq c (mod (char-code (read-char)) 128)
           c (if (= c escape)
                 (throw 'abort nil)
                 (aref meta-field (+ table c)))
           c (case (ash c -4)
               (0 c)
               (1 (case (logand c #x0f)
                    (0 (setq base 16)
                       :base)
                    (1 :backspace)
                    (2 :name)
                    (3 :enter)
                    (4 (throw 'abort nil))
                    (t (go :begin))))
               (t (setq base (ash c -4))
                  :base)))
     (if ghost-answer
         (progn (setq ghost-answer nil)
                (erase-in-line)))
     :skip
     (case c
       (:enter (return (if (zerop n) default v)))
       (:backspace (or (zerop n)
                       (progn (backspace)
                              (setq n (1- n) v (floor v base)))))
       (:name (backspace n)
              (write-string (coerce (reverse name) 'string))
              (finish-output)
              (prog (c (n (length name)) (escape (aref meta-field #xff0))
                     (table (+ (ash (aref meta-field #xfee) 8) (aref meta-field #xfef)))) :begin
                     (clear-input)
                     (setq c (mod (char-code (read-char)) 128)
                           c (if (= c escape)
                                 (throw 'abort nil)
                                 (aref meta-field (+ table c)))
                           c (case c
                               (255 :enter)
                               (254 :backspace)
                               (253 (return))
                               (252 (throw 'abort nil))
                               (t (aref character-set (mod c 128)))))
                     (case c
                       (:enter (or name (return-from read-integer default))
                               (let* ((n (coerce (reverse name) 'string))
                                      (p (name-position n))
                                      (r (if (not (zerop p)) (cddr (find-name n)))))
                                 (if (and (integerp r)
                                          (>= limit r))
                                     (progn (setq latest-name p)
                                            (return-from read-integer r)))))
                       (:backspace (or (zerop n)
                                       (progn (backspace)
                                              (setq n (1- n) name (cdr name)))))
                       (t (if (> 15 n)
                              (progn (write-char c)
                                     (push c name)
                                     (incf n)))))
                     (finish-output)
                     (go :begin))
              (backspace (length name))
              (write-string (if (zerop v) "" (princ-to-string v))))
       (:base (backspace n)
              (setq *print-base* base
                    c (if (zerop v) "" (princ-to-string v))
                    n (length c))
              (write-string c))
       (t (and (> base c)
               (let ((r (+ c (* v base))))
                 (if (and (>= limit r)
                          (> length n))
                     (progn (write-char (char character-set c))
                            (setq v r n (1+ n))))))))
     (finish-output)
     (go :begin)))

(defun show (question &optional (stream *standard-output*) &aux (*standard-output* stream))
  "Show a question to the user."
  (erase-in-line)
  (write-string question)
  (finish-output))

(defun ask (type value &optional default ignore-table)
  ""
  (unwind-protect (ecase type
                    (:size (read-integer value default))
                    (:size-name (read-integer value default t))
                    (:length (read-limited-line value default ignore-table)))
    (and use-color (setf (foreground) :default))))

(defun meta-chip-8 (caller address &aux (bottom (loop with a = top-address repeat (max 0 (1- rows)) doing (setq a (fronttrack a)) finally (return a)))
                                        (range-size (- (fronttrack caller) caller)))
  (declare (type (unsigned-byte 12) caller address))
  "Execute Meta-CHIP-8 from ADDRESS until encountering a finishing instruction."
  (setq modified-addresses nil)
  (cursor-character-absolute show-home)
  ;(fill meta-field 0 :start #xFF8)
  (fill meta-field 0 :start #xFFA)
  (setf (aref meta-field #xFFE) (ash (logand #xF00 address) -8)
        (aref meta-field #xFFF) (logand #xFF address)
        (aref meta-field #xFF2) (ash (logand #xF00 caller) -8)
        (aref meta-field #xFF3) (logand #xFF caller)
        (aref meta-field #xFF5) 2
        (aref meta-field #xFF6) (aref field caller)
        (aref meta-field #xFF7) (aref field (ldb (byte 12 0) (1+ caller))))
  (prog (pc in imp 1st 2nd a1 a2 pcinc (first t) (it 0) (escape (aref meta-field #xff0))) :begin
        (let ((c (read-char-no-hang)))
          (and c (> it 4095) (= escape (char-code c)) (throw 'abort nil)))
        (setq pc (logand #xFFF (logior (ash (aref meta-field #xFFE) 8)
                                       (aref meta-field #xFFF)))
              pcinc 3)
        (if (< #xFDF pc #xFE8)
            (return (case pc
                      (#xFE0 (throw 'quit nil))
                      (#xFE1 (jump (dpb (aref meta-field #xFE0) (byte 4 8) (aref meta-field #xFE1))))
                      (#xFE2 (or first (show-row))
                             (up))
                      (#xFE3 (or first (show-row))
                             (down))
                      (#xFE4 (save (dpb (aref meta-field #xFE0) (byte 4 8) (aref meta-field #xFE1))
                                   (dpb (aref meta-field #xFE2) (byte 4 8) (aref meta-field #xFE3))
                                   (not (zerop (aref meta-field #xFE4)))))
                      (#xFE5 (instate))
                      (#xFE6 (insert (dpb (aref meta-field #xFE0) (byte 4 8) (aref meta-field #xFE1))))
                      (#xFE7 (shift (dpb (aref meta-field #xFE0) (byte 4 8) (aref meta-field #xFE1)))))))

        ;This is an awful hack due to not being able to fit an additional few instructions in a routine.
        ;Worse yet, a simple incrementing is not enough, due to the way these routines were written.
        ;As an example, the former will become the latter:
        ;Save VO-V1; I ← I + 1 + 01
        ;Save VO-V1; I ← I + 02
        (if (or (= pc #xC22) (= pc #xC38) (= pc #xC4E) (= pc #xC64))
            (let* ((first (aref meta-field #xAC9))
                   (second (aref meta-field #xACA))
                   (integer (parse-integer (format nil "~c~c"
                                                   (char character-set first)
                                                   (char character-set second)))))
              (show (format nil "; I ← I + ~2,'0d" (1+ integer)))
              (go :end)))

        (setf (aref meta-field #xFF4) (random 256)
              first nil)
        (setq in (logior (ash (aref meta-field pc) 16)
                         (ash (aref meta-field (1+ pc)) 8)
                         (aref meta-field (+ 2 pc)))
              1st (ash (logand in #xF00000) -20)
              2nd (ash (logand in #x000F00) -8)
              imp (logior pc #x0FF)
              a1 (logior (logand #xF00 pc) (ash (logand in #x0FF000) -12))
              a2 (logand in #x000FFF))
        (case 1st
          (0 (setf (aref meta-field a1) (aref meta-field a2)))
          (1 (setf (aref meta-field a2) (aref meta-field a1)))
          (2 (setf (aref meta-field a1) (aref meta-field a2) (aref meta-field (1+ a1)) (aref meta-field (1+ a2))))
          (3 (setf (aref meta-field a2) (aref meta-field a1) (aref meta-field (1+ a2)) (aref meta-field (1+ a1))))
          (4 (setf (aref meta-field a1) (aref field a2)))
          (5 (setf (aref field a2) (aref meta-field a1)) (cleanse a2)
             (push a2 modified-addresses))
          (6 (setf (aref meta-field a1) (aref field a2) (aref meta-field (1+ a1)) (aref field (ldb (byte 12 0) (1+ a2)))))
          (7 (setf (aref field a2) (aref meta-field a1) (aref field (ldb (byte 12 0) (1+ a2))) (aref meta-field (1+ a1)))
             (cleanse a2) (cleanse (ldb (byte 12 0) (1+ a2)))
             (push a2 modified-addresses)
             (push (ldb (byte 12 0) (1+ a2)) modified-addresses))
          (8 (let* ((i (dpb (aref meta-field a1) (byte 8 8) (aref meta-field (1+ a1))))
                    (c (ldb (byte 4 12) i))
                    (s (case c
                         ((0 1 2 #xA #xB) (list 1 c (ldb (byte 4 8) i) (ldb (byte 8 0) i)))
                         ((3 4 6 7 #xC #xE #xF) (list 2 c (ldb (byte 4 8) i) (ldb (byte 8 0) i)))
                         ((5 8 9 #xD) (list 3 c (ldb (byte 4 8) i) (ldb (byte 4 4) i) (ldb (byte 4 0) i))))))
               (replace meta-field s :start1 a2 :end1 (+ a2 (length s)))))
          (9 (let* ((1b (logand #x0F (aref meta-field (1+ a2))))
                    (2b (aref meta-field (+ 2 a2)))
                    (3b (aref meta-field (+ 3 a2)))
                    (i (case (aref meta-field a2)
                         (0 `(,(logior (ash 1b 4) (ash (logand #xF0 2b) -4))
                               ,(logior (ash (logand #x0F 2b) 4) (logand #x0F 3b))
                               ,(aref meta-field (+ 4 a2))))
                         ((1 2) `(,(logior (ash 1b 4) (logand #x0F 2b)) ,3b))
                         (3 `(,(logior (ash 1b 4) (logand #x0F 2b))
                               ,(logior (ash (logand #x0F 3b) 4) (logand #x0F (aref meta-field (+ 4 a2)))))))))
               (replace meta-field i :start1 a1 :end1 (+ a1 (length i)))))
          (10 (show (map 'string (lambda (c) (char character-set c)) (subseq meta-field a2 (+ a2 (logand #xFF a1))))))
          (11 (replace meta-field (map 'vector (lambda (c) (position c character-set)) (ask :length (logand #xFF a1)))
                       :start1 a2 :end1 (+ a2 (logand #xFF a1)))
              (cursor-character-absolute show-home)
              (erase-in-line)
              (setf (aref meta-field imp) latest-name))
          ((12 13) (let* ((limit (dpb (aref meta-field a1) (byte 8 8) (aref meta-field (1+ a1))))
                          (ghost-answer (if (> 256 limit)
                                            (aref meta-field a2)
                                            (dpb (aref meta-field a2) (byte 8 8) (aref meta-field (1+ a2)))))
                          (answer (ask (if (evenp 1st) :size :size-name) limit)))
                     (cursor-character-absolute show-home)
                     (erase-in-line)
                     (if answer (setf (aref meta-field (1- imp)) (logand #x0F00 latest-name)
                                      (aref meta-field imp) (logand #x00FF latest-name)))
                     (if answer (if (> 256 limit)
                                    (setf (aref meta-field a2) answer)
                                    (setf (aref meta-field a2) (ash answer -8)
                                          (aref meta-field (1+ a2)) (logand #xFF answer))))))
          (15 (return))
          (14 (let* ((a2 (logior (logand #xF00 pc) (logand in #xFF))) (c1 (aref meta-field a1)) (c2 (aref meta-field a2)))
                (case 2nd
                  (0 (setf (aref meta-field imp) (ash (logand #x100 (+ c1 c2)) -8)
                           (aref meta-field a2) (logand #xFF (+ c1 c2))))
                  (1 (setf (aref meta-field imp) (if (<= 0 (ash (logand #x100 (+ c1 c2)) -8)) 1 0)
                           (aref meta-field a2) (logand #xFF (- c1 c2))))
                  (2 (setf (aref meta-field imp) (ldb (byte 1 7) c1)
                           (aref meta-field a2) (ldb (byte 8 0) (ash c1 1))))
                  (3 (setf (aref meta-field imp) (ldb (byte 1 0) c1)
                           (aref meta-field a2) (ash c1 -1)))
                  (4 (incf pcinc (if (= c1 c2) 3 0)))
                  (5 (incf pcinc (if (= c1 c2) 0 3)))
                  (6 (replace meta-field (map 'list 'digit-char-p (format nil "~3,'0d" c1)) :start1 a2 :end1 (+ 3 a2)))
                  (7 (replace meta-field (map 'list 'digit-char-p (format nil "~5,'0d" (logior (ash c1 8) (aref meta-field (1+ a1)))))
                              :start1 a2 :end1 (+ 5 a2)))
                  (8 (setf (aref meta-field a2) (logand c1 c2)))
                  (9 (setf (aref meta-field a2) (logior c1 c2)))
                  (10 (setf (aref meta-field a2) (logxor c1 c2)))
;                  (11 (let* ((a (subseq meta-field a2 (+ 20 a2)))
;                             (c (dpb (aref a 0) (byte 4 8) (aref a 1))))
;                        (case (ldb (byte 4 0) a1)
;                          (0 (replace meta-field (let (subseq )
;                                                   )
;                                      :start1 (+ 2 a2) :end1 (+ 2 a2 ())))
;                          (1 )
;                          (2 )
;                          (3 )
;                          (4 (delete-name c)))))
                  (11 (let* ((a (subseq meta-field a2 (+ 20 a2)))
                             (c (dpb (aref a 0) (byte 4 8) (aref a 1)))
                             (v (dpb (aref a 2) (byte 8 8) (aref a 3)))
                             (s (ldb (byte 4 0) (aref a 4)))
                             (l (ldb (byte 1 4) (aref a 4)))
                             (n (subseq a 5 (+ 5 s)))
                             (m (map 'string (lambda (c) (char character-set c)) n))
                             (p (name-position m))
                             (f (find-name m)))
                        (case (ldb (byte 4 0) a1)
                          (0 (let* ((f (aref names c))
                                    (v (or (cddr f) 0)))
                               (replace meta-field (list* (ldb (byte 4 8) v)
                                                          (ldb (byte 8 0) v)
                                                          (dpb (if (car f) 1 0) (byte 1 4) (length (cadr f)))
                                                          (map 'list (lambda (c) (position c character-set))
                                                               (cadr f)))
                                        :start1 (+ 2 a2) #| :end1 (+ a2 2 (length (cadr f))) |#)))
                          (5 (setq p (label-position v)
                                   l (if (zerop p) 0 1)
                                   n (map 'vector (lambda (c) (position c character-set)) (cadr (aref names p)))
                                   s (length n))
                             (replace meta-field (list* (ldb (byte 4 8) p)
                                                        (ldb (byte 8 0) p)
                                                        (ldb (byte 4 8) v)
                                                        (ldb (byte 8 0) v)
                                                        (dpb l (byte 1 4) s)
                                                        (coerce n 'list))
                                      :start1 a2 #| :end1 (+ 20 a2) |#))
                          (2 (let ((code (change-name m v (not (zerop l)))))
                               (replace meta-field (list (ldb (byte 4 8) code)
                                                         (ldb (byte 8 0) code))
                                        :start1 a2 :end1 (+ 2 a2))))
                          (3 (let ((code (create-name m v (not (zerop l)))))
                               (replace meta-field (list (ldb (byte 4 8) code)
                                                         (ldb (byte 8 0) code))
                                        :start1 a2 :end1 (+ 2 a2))))
                          (1 (delete-name c))
                          (4 (replace meta-field (list* (ldb (byte 4 8) (ldb (byte 4 8) p))
                                                        (ldb (byte 8 0) (ldb (byte 8 0) p))
                                                        (ldb (byte 4 8) (ldb (byte 4 8) (cddr f)))
                                                        (ldb (byte 8 0) (ldb (byte 8 0) (cddr f)))
                                                        (dpb l (byte 1 4) (if (car f) 0 1))
                                                        (coerce n 'list))
                                      :start1 a2 #| :end1 (+ 20 a2) |#)))))
                  ((12 13 14 15) (let ((d1 (dpb (ldb (byte 4 0) (aref meta-field a1)) (byte 4 8) (aref meta-field (1+ a1))))
                                       (d2 (dpb (ldb (byte 4 0) (aref meta-field a2)) (byte 4 8) (aref meta-field (1+ a2))))
                                       (d3 (ldb (byte 3 4) (aref meta-field a1)))
                                       (d4 (ldb (byte 3 4) (aref meta-field a2))))
                                   (case 2nd
                                     (12 (setf (aref meta-field a2) (dpb (ldb (byte 3 0) (aref name-assoc d1))
                                                                         (byte 3 4)
                                                                         (ldb (byte 4 8) (aref name-table d1)))
                                               (aref meta-field (1+ a2)) (ldb (byte 8 0) (aref name-table d1))))
                                     (13 (setf (aref name-assoc d1) (if (zerop d2) 0 d4) ;arrangement
                                               (aref name-table d1) d2)) ;name
                                     (14 (setf (aref meta-field a2) (ldb (byte 4 8) (aref routines d1))
                                               (aref meta-field (1+ a2)) (ldb (byte 8 0) (aref routines d1))))
                                     (15 (setf (aref routines d1) d2)))))))))
        :end
        (setf (aref meta-field #xFFC) (ldb (byte 4 8) pc)
              (aref meta-field #xFFD) (ldb (byte 8 0) pc)
              (aref meta-field #xFFA) (ldb (byte 4 8) (+ 3 pc))
              (aref meta-field #xFFB) (ldb (byte 8 0) (+ 3 pc))
              it (1+ it))
        (and (= pc (dpb (aref meta-field #xFFE) (byte 4 8) (aref meta-field #xFFF)))
             (incf pc pcinc)
             (setf (aref meta-field #xFFE) (ldb (byte 4 8) pc)
                   (aref meta-field #xFFF) (ldb (byte 8 0) pc)))
        (go :begin))
  (if modified-addresses
      (unless (and (every (lambda (n) (or (> top-address n)
                                          (< bottom n)
                                          (<= caller n (+ caller (aref meta-field #xFF5)))))
                          modified-addresses)
                   (= range-size (aref meta-field #xFF5)))
        (setq redisplay-needed t)))
  (aref meta-field #xFF5))

(defun mmc-chip-8 (meta &aux error)
  ""
  (if (probe-file (make-pathname :name ".mmc-no-color" :defaults (user-homedir-pathname)))
      (setq use-color nil))
  (if (probe-file (make-pathname :name ".mmc-show-as-stacked" :defaults (user-homedir-pathname)))
      (setq show-as-stacked t
            home (- home 8)
            show-home (- show-home 8)))
  (with-open-file (s (make-pathname :name ".mmc-binary-characters" :defaults (user-homedir-pathname))
                     :if-does-not-exist nil)
    (if s (setq zero-character (read-char s nil #\0)
                one-character (read-char s nil #\1))))
  (if (setq error (second (multiple-value-list
                           (ignore-errors
                             (with-open-file (file meta :element-type '(unsigned-byte 8) :if-does-not-exist :error)
                               (read-sequence meta-field file))
                             (catch 'quit
                               (catch 'abort (redraw-display))
                               (prog (table address event) :begin
                                     (finish-output)
                                     (clear-input)
                                     (setq table (dpb (aref meta-field #xFEA) (byte 4 8) (aref meta-field #xFEB)))
                                     (unread-char (read-char))
                                     (setq event (read-event-no-hang))
                                     ;(setq event (read-char))
                                     (cond ((characterp event)
                                            (setq address (+ table (ash (ldb (byte 7 0) (char-code event)) 1)))
                                            (go :continue))
                                           ((and (listp event) (eql :mouse (car event)))
                                            (let ((r (fourth event)))
                                              (if (> current-row r)
                                                  (loop repeat (- current-row r) doing (up))
                                                  (if (< current-row r)
                                                      (loop repeat (- r current-row) doing (down))))))
                                           ((eql :scroll-down event) (down))
                                           ((eql :scroll-up event) (up)))
                                     (go :begin)
                                     :continue
                                     (catch 'abort (meta-chip-8 current-address
                                                                (dpb (aref meta-field address) (byte 4 8) (aref meta-field (1+ address)))))
                                     (if redraw-row (show-row))
                                     (if redisplay-needed (redraw-display))
                                     (setq redraw-row t redisplay-needed nil)
                                     (finish-output)
                                     (go :begin)))))))
      (progn (erase)
             (setf (cursor) ())
             (show (format nil "An error has occured:~%~a~&~
If this is relating to the META-FIELD value being overindexed, it is likely a Meta-CHIP-8 programming error.
If not, this is likely due to a flaw in the MMC itself and should likely be reported for correction.~%" error))
             (catch 'abort (ask :length 0))
             (tagbody :begin
                (show "Do you want to attempt to save?  You must answer with a \"yes\" if so. ")
                (if (string-equal "yes" (catch 'abort (ask :length 3 "" t)))
                    (save (if (every 'zerop (subseq field 0 200)) #x200 0)
                          4095))
                (show "Do you want to exit now?  You must answer with a \"yes\" if so. ")
                (unless (string-equal "yes" (catch 'abort (ask :length 3 "" t)))
                  (go :begin)))))
  (erase)
  (setf (cursor) ())
  (quit))

;#b01 #xF000 #x0000 "Jump to COSMAC VIP NNNN" (12 0) "Address"
;#b01 #xFFF0 #x00C0 "Scroll ↓ by NN" (4 0) "Shift amount"
;#b01 #xFFF0 #x00D0 "Scroll ↑ by NN" (4 0) "Shift amount"
;#b01 #xFFFF #x00E0 "Clear the screen"
;#b01 #xFFFF #x00EE "Return"
;#b01 #xFFFF #x00FB "Scroll → by 04"
;#b01 #xFFFF #x00FC "Scroll ← by 04"
;#b01 #xFFFF #x00FD "Exit program"
;#b01 #xFFFF #x00FE "Disable extended mode"
;#b01 #xFFFF #x00FF "Enable extended mode"
;#b01 #xF000 #x1000 "Jump to NNNN" (12 0) "Address"
;#b01 #xF000 #x2000 "Call NNNN" (12 0) "Address"
;#b10 #xF000 #x3000 "Skip next if VX = NNN" (4 8) "Register" (8 0) "Value"
;#b10 #xF000 #x4000 "Skip next if VX <> NNN" (4 8) "Register" (8 0) "Value"
;#b11 #xF00F #x5000 "Skip next if VX = VY" (4 8) "First register" (4 4) "Second register"
;#b10 #xF000 #x6000 "VX ← NNN" (4 8) "Register" (8 0) "Value"
;#b10 #xF000 #x7000 "VX ← VX + NNN" (4 8) "Register" (8 0) "Value"
;#b11 #xF00F #x8000 "VX ← VY" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8001 "VX ← VX OR VY" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8002 "VX ← VX AND VY" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8003 "VX ← VX XOR VY" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8004 "VX ← VX + VY; VF ← overflow" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8005 "VX ← VX − VY; VF ← borrow" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8006 "VX ← VY ÷ 2; VF ← LSB" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x8007 "VX ← VY − VX; VF ← borrow" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x800E "VX ← VY × 2; VF ← MSB" (4 8) "First register" (4 4) "Second register"
;#b11 #xF00F #x9000 "Skip next if VX <> VY" (4 8) "First register" (4 4) "Second register"
;#b01 #xF000 #xA000 "I ← NNNN" (12 0) "Address"
;#b01 #xF000 #xB000 "Jump to V0 + NNNN" (12 0) "Address"
;#b10 #xF000 #xC000 "VX ← ??? AND NNN" (4 8) "Register" (8 0) "Mask"
;#b11 #xF000 #xD000 "Draw 08×NN at VX,VY; VF ← XOR" (4 8) "First register" (4 4) "Second register" (4 0) "Height"
;#b11 #xF00F #xD000 "Draw 16x16 at VX,VY; VF ← XOR" (4 8) "First register" (4 4) "Second register"
;#b10 #xF0FF #xE09E "Skip next if VX = key" (4 8) "Register"
;#b10 #xF0FF #xE0A1 "Skip next if VX <> key" (4 8) "Register"
;#b10 #xF0FF #xF007 "VX ← delay" (4 8) "Register"
;#b10 #xF0FF #xF00A "VX ← key" (4 8) "Register"
;#b10 #xF0FF #xF015 "delay ← VX" (4 8) "Register"
;#b10 #xF0FF #xF018 "sound ← VX" (4 8) "Register"
;#b10 #xF0FF #xF01E "I ← I + VX" (4 8) "Register"
;#b10 #xF0FF #xF029 "I ← digit sprite of VX" (4 8) "Register"
;#b10 #xF0FF #xF030 "I ← large digit sprite of VX" (4 8) "Register"
;#b10 #xF0FF #xF033 "VX as BCD stored from I" (4 8) "Register"
;#b10 #xF0FF #xF055 "Save VO-VX; I ← I + 1 + VX" (4 8) "Register"
;#b10 #xF0FF #xF065 "Load VO-VX; I ← I + 1 + VX" (4 8) "Register"
;#b10 #xF0FF #xF075 "Save VO-VX to environment; I ← I + 1 + VX" (4 8) "Register"
;#b10 #xF0FF #xF085 "Load VO-VX to environment; I ← I + 1 + VX" (4 8) "Register"
(mmc-chip-8 (let ((default (make-pathname :name "map" :type "mc8" :defaults (user-homedir-pathname)))
                  (hidden (make-pathname :name ".map" :type "mc8" :defaults (user-homedir-pathname))))
              (cond ((probe-file default) default)
                    ((probe-file hidden) hidden)
                    (t (prog (answer) :begin
                             (erase)
                             (setf (cursor) ())
                             (show "Filename ")
                             (setq answer (catch 'abort (ask :length 128 nil t)))
                             (and answer (probe-file answer) (return answer))
                             (erase)
                             (setf (cursor) ())
                             (show "That is an invalid filename.")
                             (catch 'abort (ask :length 0 nil t))
                             (erase)
                             (setf (cursor) ())
                             (show "Do you want to exit? ")
                             (if (string-equal "yes" (catch 'abort (ask :length 3 "" t)))
                                 (progn (erase)
                                        (setf (cursor) ())
                                        (quit)))
                             (go :begin))))))
.