#|
;; emacs eev eepitch lines.
• (setq inferior-lisp-program "ecl")
• (setq eepitch-buffer-name "*slime-repl ECL*")
• (slime)

(ql:quickload :McCLIM)

(compile-file "~/Downloads/nicclim.lisp" :load t)

(string '~/game)
(ensure-directories-exist *)
(uiop:chdir **)
(uiop:chdir ***) ; tbh I don't know why I need to do this twice.

(in-package :nicclim)

|#

(require :asdf)
(require :mcclim)

(uiop:define-package :NicCLIM
    (:mix :clim :clim-lisp :cl)
  (:export #:enclose-map #:toggle-log-to-error
	   #:rect-file #:clobber-rect #:extract-rect
	   #:vertical-cat #:horizontal-cat #:cat
	   #:*nic*

	   #:spacetime-box

	   #:empty-pattern-cache

	   #:*hextille-offset)
  (:nicknames #:nic))

(in-package :NicCLIM)

(define-command-table v3-command-table
  :menu (("bitmap" :menu (("set bitmap" :command com-set-bitmap)
			  ("get bitmap" :command com-get-bitmap)))
	 ("cursor" :menu (("set-cur1 C-M-u"	:command com-set-cur1	)
			  ("swap-curs C-S-i"	:command com-swap		)
			  ("push-cur1 C-M-o"	:command com-push-cur1	)
			("s/cur1/cur2/g C-S-p"	:command com-s/cur1/cur2/g	)
			  ("delcur C-M-p"	:command com-delcur	)
			  ("rotcell C-S-o"	:command com-rot-cell	)
			  ("cur1-rotatef M-S-f" :command com-cur1-rotatef)
			  ("note-location M-S-v"	:command com-note-location)
			  ("select M-="		:command com-select)
			  ("deselect M-_"	:command com-deselect)))
	 ("mov" :menu (("H M-S-h"		:command com-h		)
		       ("j M-S-j"		:command com-j		)
		       ("k M-S-k" 		:command com-k		)
		       ("jh C-M-S-j"		:command com-jh		)
		       ("kl C-M-S-k" 		:command com-kl		)
		       ("l M-S-l"		:command com-l		)
		       ("jump C-M-i"		:command com-jump		)
		       ("vec-mov C-S-i"		:command com-vec-mov)	))
	 ("addrem" :menu (("add-row C-M-m"	:command com-add-row	)
			  ("add-cell C-M-n"	:command com-add-cell	)
			  ("rem-cell C-S-n"	:command com-rem-cell	)
			  ("rem-row C-S-m"	:command com-rem-row	)))
	 ("layouts:" :menu
		    (("key-layout C-1" :command com-keys-layout)
		     ("default C-2" :command com-normal-layout)
		     ("map-layout C-3" :command com-map-layout)
		     ("min-layout C-4" :command com-min-layout)))
	 ("Rect!" :menu
		  (("create-rect" :command com-create-rect)
		   ("horizontal-cat" :command com-horizontal-cat)
		   ("vertical-cat" :command com-vertical-cat)
		   ("extract-rect" :command com-extract-rect)
		   ("clobber-rect" :command com-clobber-rect)
		   ("change-map" :command com-change-map)
		   ("chdir" :command com-chdir)
		   ("mkdir" :command com-mkdir)
		   ("cat" :command com-cat)
		   ("writef" :command com-writef)
		   ("rect-intersection M-S-z" :command com-rect-intersection)
		   ("rect-difference M-S-x" :command com-rect-difference)
		   ("rect-union M-S-c" :command com-rect-union)
		   ("directory" :command com-directory)))
	 ("lisp" :menu
		 (("funcall cur1 cell M-S-q" :command com-funcall)
		  ("apply cur1 cell M-S-w" :command com-apply)))
	 ("macro" :menu
		  (("execute-list cur1 M-S-b" :command com-execute-list)
		   ("doas M-S-s" :command com-doas)
		   ("doas list M-S-d" :command com-doas-list)))
	 ("player" :menu
		   (("gets cur1 M-S-e" :command com-gets)
		    ("setsgets player cur2->cur1 M-S-r" :command com-setsgets)
		    ("change player M-S-t" :command com-change-player)
		    ("extract player M-S-a" :command com-extract-player)))))

(define-application-frame map-editor ()
  ((table-list :initarg :table-list)
   (player :initform :player :accessor player)
   (cursor-locn :initarg :cursor-locn)
   (cur1 :initform nil)
   (cur2 :initform nil)
   (help-table
    :initform
    '((com-keys-layout (#\1 :control))
      (com-normal-layout (#\2 :control))
      (com-map-layout (#\3 :control))
      (com-min-layout (#\4 :control))
      (com-set-cur1 (#\u :control :meta))
      (com-swap (#\I :control))
      (com-push-cur1 (#\o :control :meta))
      (com-s/cur1/cur2/g (#\P :control))
      (com-delcur (#\p :control :meta))
      (com-rot-cell (#\O :control))
      (com-h (#\H :meta))
      (com-j  (#\J :meta))
      (com-k  (#\K :meta))
      (com-l  (#\L :meta))
      (com-jh (#\J :control :meta))
      (com-kl (#\K :control :meta))
      (com-jump  (#\i :control :meta))
      (com-vec-mov  (#\I :control))
      (com-add-row  (#\m :control :meta))
      (com-add-cell  (#\n :control :meta))
      (com-rem-cell  (#\N :control))
      (com-rem-row  (#\M :control ))
      (log-map  (#\l :meta))
      (com-create-rect)
      (com-horizontal-cat)
      (com-vertical-cat)
      (com-extract-rect)
      (com-clobber-rect)
      (com-change-map)
      (com-cat)
      (com-chdir)
      (com-mkdir)
      (com-writef)
      (com-directory)
      (com-execute-list (#\B :meta))
      (com-funcall (#\Q :meta))
      (com-apply (#\W :meta))
      (com-gets (#\E :meta))
      (com-setsgets (#\R :meta))
      (com-change-player  (#\T :meta))
      (com-extract-player (#\A :meta))
      (com-doas (#\S :meta))
      (com-doas-list (#\D :meta))
      (com-rect-union (#\C :meta))
      (com-rect-intersection (#\Z :meta))
      (com-rect-difference (#\X :meta))
      (com-cur1-rotatef (#\F :meta))
      (com-note-location (#\V :meta))
      (com-get-bitmap)
      (com-set-bitmap)
      (com-peek)
      (com-select (#\= :meta))
      (com-deselect (#\_ :meta)))))
  (:menu-bar v3-command-table)
  (:panes
   (int :interactor)
   (cursor-info :application
		:display-function
		(lambda (f p)
		  (with-slots
			(cursor-locn table-list)
		      f
		    (princ "x=" p)
		    (princ (cadr cursor-locn) p)
		    (terpri p)
		    (princ "y=" p)
		    (princ (car cursor-locn) p)
		    (terpri p)
		    (princ "has " p)
		    (ignore-errors
		     (princ (nth (cadr cursor-locn)
				 (nth (car cursor-locn)
				      table-list))
			    p)))))
   (cur-contents :application
		 :display-function
		 (lambda (f p)
		   (with-slots
			 (cur1 cur2)
		       f
		     (princ "cur1=" p)
		     (princ cur1 p)
		     (terpri p)
		     (princ "cur2=" p)
		     (princ cur2 p))))
   (map :application
	:display-function 'map-display
	:incremental-redisplay t)
   (help :application
	 :display-function 'help-display
	 :scroll-bars :vertical))
  (:layouts
   (normal 
    (horizontally ()
      (vertically ()
	int
	(horizontally () cursor-info cur-contents))
      (2/3 map)))
   (keys-layout
    (vertically ()
      (5/6
       (horizontally ()
	 (vertically () (1/5 int)
		     help)
	 map))
      (horizontally ()
	cursor-info cur-contents)))
   (map-layout
    (vertically ()
      (1/8 int) map))
   (min-layout
    (vertically ()
      int
      (horizontally ()
	cursor-info cur-contents))))
  (:default-initargs :cursor-locn '(0 0)))

(defun help-display (f p)
  (with-slots
	(help-table)
      f
    (formatting-table
	(p)
      (loop
	:for row :in help-table :do
	  (formatting-row
	      (p)
	    (formatting-cell
		(p)
	      (present row (presentation-type-of row) :stream p)))))))

(defvar *hextille-offset* 32
  "Adjust how much oddp rows are offset viz hextille")

(defun map-display (frame pane)
  (flet ((get-offset (n) (cond
			   ((oddp n) *hextille-offset*)
			   ((evenp n) 0)
			   (t (error "Neither odd nor even")))))
  (formatting-table
      (pane)
    (with-slots
	  (table-list cursor-locn)
	frame
      (loop :for r :from 0
	    :for row :in table-list :do
	      (with-translation (pane (get-offset r) 0)
	      (formatting-row 
		  (pane)
		(loop :for c :from 0
		      :for cell :in row :do
			(formatting-cell
			    (pane)
			  (updating-output
			      (pane)
			    (surrounding-output-with-border
				(pane)
			      (with-text-style
				  (pane
				   (make-text-style
				    :sans-serif :roman :tiny))
				(loop :initially
				  (format pane "~@[@~%~](~d ~d)"
					  (and (= (cadr cursor-locn) c)
					       (= (car cursor-locn) r))
					  c r)
				      :for symbol :in cell
				      :if (and (symbolp symbol)
					       (get symbol :bitmap)) :do
					(maybe-render-bitmap symbol pane)
				      :else 
					:do (fresh-line pane)
					    (present symbol 'expression
						     :stream pane))))))))))))))

(defun enclose-map (file)
  "enclose-map (file) is the intended way of starting the frame
The file is thought to be READ-DELIMITED-LIST suitable."
  (let
      ((lists
	 (with-open-file
	     (in (string file))
	   (loop
	     :collect (handler-case
			  (read-delimited-list #\newline in)
			(end-of-file (e) (declare (ignore e))
			  (return lists)))
	       :into lists))))
    ;; Run the application-frame.
    (setf lists
	  (let ((frame (make-application-frame
			'map-editor
			:table-list lists)))
	    (defparameter *nic* frame)
	    (run-frame-top-level frame)
	    (with-slots (table-list) frame
	      table-list)))
    ;; Print
    (format
     t
     "~{~{~s~^	~}~%~}"
     lists)
    ;; Overwrite file?
    (when
	(y-or-n-p "Clobber ~a? y/n" file)
      (with-open-file
	  (out (string file) :direction :output
		    :if-exists :supersede)
	(format
	 out
	 "~{~{~s~^	~}~%~}"
	 lists)))))

;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;; COMMANDS⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇


;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; LAYOUT COMMANDS≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-keys-layout :keystroke (#\1 :control))
    ()
  (setf (frame-current-layout *application-frame*)
	'keys-layout))

(define-map-editor-command (com-normal-layout :keystroke (#\2 :control))
    ()
  (setf (frame-current-layout *application-frame*)
	'normal))

(define-map-editor-command (com-map-layout :keystroke (#\3 :control))
    ()
  (setf (frame-current-layout *application-frame*)
	'map-layout))

(define-map-editor-command (com-min-layout :keystroke (#\4 :control))
    ()
  (setf (frame-current-layout *application-frame*)
	'min-layout))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; CURSOR COMMANDS≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-set-cur1 :name t :keystroke (#\u :control :meta))
    ((cur1i 'expression :default NIL)) ;; v2
  "sets cur1 to a symbol."
  (with-slots
	(cur1)
      *application-frame*
    (setf cur1 cur1i)))

(define-map-editor-command (com-swap :name t :keystroke (#\I :control))
    ()
  "swaps cur1 and cur2"
  (with-slots
	(cur1 cur2)
      *application-frame*
    (psetf cur2 cur1 cur1 cur2)))
  
(define-map-editor-command (com-push-cur1 :name t :keystroke (#\o :control :meta))
    ()
  "pushes cursor 1 to the current cell"
  (with-slots
	(table-list cursor-locn cur1)
      *application-frame*
    (cond
      ((nth (cadr cursor-locn) 
	  (nth (car cursor-locn)
	       table-list))
       (nconc
	(nth (cadr cursor-locn) 
	     (nth (car cursor-locn)
		  table-list))
	(list cur1)))
      (t
       (setf (nth (cadr cursor-locn) 
		  (nth (car cursor-locn)
		       table-list))
	     `(,cur1))))))

(define-map-editor-command (com-s/cur1/cur2/g :name t :keystroke (#\P :control))
    ()
  "s/cur1/cur2/g (in current cell)"
  (with-slots
	(table-list cursor-locn
	 cur1 cur2)
      *application-frame*
    (setf
     (nth (cadr cursor-locn) 
	  (nth (car cursor-locn)
	       table-list))
     (nsubst
      cur2
      cur1
      (nth (cadr cursor-locn) 
	   (nth (car cursor-locn)
		table-list))))))

(define-map-editor-command (com-delcur :name t :keystroke (#\p :control :meta))
    ()
  "Deletes cur1 from current cell"
  (with-slots
	(table-list cursor-locn
	 cur1)
      *application-frame*
    (setf (nth (cadr cursor-locn) 
	       (nth (car cursor-locn) table-list))
     (delete cur1
	     (nth (cadr cursor-locn) 
		  (nth (car cursor-locn) table-list))
	     :test 'equal))))

(define-map-editor-command (com-rot-cell :name t :keystroke (#\O :control))
    ((n 'integer :default 1))
  "rot-cell takes an integer and rotates the current cell that much."
  (with-slots
	(table-list cursor-locn)
      *application-frame*
    (setf (nth (cadr cursor-locn) 
	       (nth (car cursor-locn) table-list))
     (alexandria:rotate
      (nth (cadr cursor-locn) 
	   (nth (car cursor-locn) table-list))
      n))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; MOVEMENT≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-h :name t :keystroke (#\H :meta))
    ()
  (with-slots
	(cursor-locn)
      *application-frame*
    (decf (cadr cursor-locn))))

(define-map-editor-command (com-j  :name t :keystroke (#\J :meta))
    ()
  (with-slots
	(cursor-locn)
      *application-frame*
    (when (oddp (car cursor-locn))
      (execute-frame-command *application-frame* '(com-l)))
    (incf (car cursor-locn))))

(define-map-editor-command (com-k  :name t :keystroke (#\K :meta))
    ()
  (with-slots
	(cursor-locn)
      *application-frame*
    (when (evenp (car cursor-locn))
      (execute-frame-command *application-frame* '(com-h)))
    (decf (car cursor-locn))))

(define-map-editor-command (com-l  :name t :keystroke (#\L :meta))
    ()
  (with-slots
	(cursor-locn)
      *application-frame*
    (incf (cadr cursor-locn))))

(define-map-editor-command (com-jump  :name t :keystroke (#\i :control :meta))
    ((x 'integer :default 0)
     (y 'integer :default 0))
  "jump to absolute integer x integer y position"
  (with-slots
	(cursor-locn)
      *application-frame*
    (setf (cadr cursor-locn) x
	  (car cursor-locn) y)))

(define-map-editor-command (com-vec-mov  :name t :keystroke (#\I :control))
    ((x 'integer :default 0)
     (y 'integer :default 0))
  "vector add integer x integer y to current position"
  (with-slots
	(cursor-locn)
      *application-frame*
    (incf (cadr cursor-locn) x)
    (incf (car cursor-locn) y)))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;adding and removing≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-add-row  :name t :keystroke (#\m :control :meta))
    ()
  "Adds a new row at row with one cell with cursor1 in it."
  (with-slots
	(table-list cursor-locn cur1)
      *application-frame*
    (multiple-value-bind
	  (row)
	(apply 'values cursor-locn)
      (cond
	((zerop row)
	 (setf table-list
	       (nconc (list (list (list cur1))) table-list)))
	(t (let ((rest (nthcdr row table-list)))
	     (setf
	      (cdr (nthcdr (1- row) table-list))
	      (nconc (list (list (list cur1))) rest))))))))

(define-map-editor-command (com-add-cell  :name t :keystroke (#\n :control :meta))
    ()
  "adds a new cell to current row, cell with cursor 1 in it"
  (with-slots
	(table-list cursor-locn cur1)
      *application-frame*
    (multiple-value-bind
	  (row col)
	(apply 'values cursor-locn)
      (cond
	((zerop col)
	 (push (list cur1) (nth row table-list)))
	(t (let ((rest (nthcdr col (nth row table-list))))
	     (setf
	      (cdr (nthcdr (1- col) (nth row table-list)))
	      (nconc (list (list cur1)) rest))))))))

(define-map-editor-command (com-rem-cell  :name t :keystroke (#\N :control))
    ()
  "removes cell at current row, col"
  (with-slots
	(table-list cursor-locn)
      *application-frame*
    (multiple-value-bind
	  (row col)
	(apply 'values cursor-locn)
      (cond
	((zerop col)
	 (pop (nth row table-list)))
	(t 
	 (pop (cdr (nthcdr (1- col) (nth row table-list)))))))))

(define-map-editor-command (com-rem-row  :name t :keystroke (#\M :control ))
    ()
  "remove row at current row"
  (with-slots
	(table-list cursor-locn)
      *application-frame*
    (multiple-value-bind
	  (row)
	(apply 'values cursor-locn)
      (cond
	((zerop row)
	 (pop table-list))
	(t 
	 (pop (cdr (nthcdr (1- row) table-list))))))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;LOGGING≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (log-map  :name t :keystroke (#\l :meta))
    ()
  "logs the current map to *terminal-io*"
  (with-slots
	(table-list cursor-locn)
      *application-frame*
    (format
     *terminal-io*
     "~{~{~s~^	~}~%~}"
     table-list)))

(let ((logging nil))  
  (defun toggle-log-to-error ()
    (if (setf logging (not logging))
	(defmethod clim:execute-frame-command :after ((frame standard-application-frame)
						      command)
	  (declare (ignore frame))
	  (print command *error-output*))
	(defmethod clim:execute-frame-command :after ((frame standard-application-frame)
						      command)
	  (declare (ignore frame command))))))

;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;; FILE-OPS ⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; FILE-OPS≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defun rect-file
    (path width height &optional (default nil)
			 (path (string path)))
  "
"
  (with-open-file (*standard-output*
		   path
		   :direction :output
		   :if-does-not-exist :create)
    (format t "~{~{~s~^	~}~%~}"
	    (loop :repeat height
		  :collect
		  (loop :repeat width :collect default)))))

(defun horizontal-cat
    (file1 file2 fileout &key (start2 0) (stop2 nil))
  "
"
  (with-open-file
      (*standard-output* fileout :direction :output :if-does-not-exist :create)
    (with-open-file
	(file-in-1 file1)
      (with-open-file
	  (file-in-2 file2)
	(handler-case
	    (loop :for x1 :from 0
		  :for line1 := (read-line file-in-1)
		  :for line2 := (when (<= start2 x1)
				  (read-line file-in-2))
		  :do
		     (princ line1)
		  :when (and line2 (or (null stop2)
				       (< x1 stop2)))
		    :do
		       (princ " ") (princ line2)
		  :do (terpri))
	  (end-of-file (e) t))))))

(defun vertical-cat
    (file1 file2 fileout
     &key
       (start1 0) (stop1 nil)
       (start2 0) (stop2 nil))
  (with-open-file
      (*standard-output* fileout :direction :output :if-does-not-exist :create :if-exists :append)
    (with-open-file
	(file-in-1 file1)
      (handler-case
	  (loop
	    :initially
	       (loop :repeat start1 :do
		 (read-line file-in-1))
	    :for x :from start1
	    :for line := (read-line file-in-1)
	    :when (and stop1 (= stop1 x))
	      :return nil
	    :do
	       (princ line)
	       (terpri))
	(end-of-file (e) t))))
    (with-open-file
	(file-in-2 file2)
      (handler-case
	  (loop :initially
	    (loop :repeat start2 :do
	      (read-line file-in-2))
	    :for x :from 2
		:for line := (read-line file-in-2)
		:when (and stop2 (= stop2 x))
		  :return nil
		:do
		   (princ line)
		   (terpri))
	(end-of-file (e) t))))

(defun extract-rect (filein fileout startrow stoprow startcol stopcol)
  (with-open-file
      (*standard-output* fileout :direction :output)
    (with-open-file
	(in filein)
      (loop :for rown :from 0
	    :for line := (read-delimited-list #\newline in)
	    :when (<= startrow rown stoprow) :do
	      (format
	       t
	       "~{~s~^	~}~%"
	       (subseq line startcol stopcol))
	    :while (< rown (1- stoprow))))))

(defun clobber-rect
    (file1 file2 fileout startrow stoprow startcol stopcol)
  "replaces a rectangle of file1 with file2 into fileout
startrow height startcol width as usual"
  (with-open-file
      (*standard-output* fileout :direction :output)
    (with-open-file
	(filein1 file1 :direction :input)
      (with-open-file
	  (filein2 file2 :direction :input)
	(handler-case
	    (loop
	      :for rown :from 0
	      :for list
		:=
		(read-delimited-list #\newline filein1)
	      :for list2
		:=
		(and (<= startrow rown)
		     (< rown stoprow)
		     (read-delimited-list #\newline
					  filein2))
	      :for list3 := (if (null list2)
				list
				(append
				 (subseq list 0 startcol)
				 list2
				 (subseq list stopcol)))
	      :do
		 (format t "~{~s	~}~%" list3))
	  (end-of-file (e) t))))))

(defun cat (file)
  (with-open-file (in file)
    (loop :for line := (read-line in nil nil)
	  :while line :do (princ line) (terpri)
	  :finally (terpri))))
	      
;;--- back to commands

(define-map-editor-command (com-create-rect :name t)
    ((path 'symbol)
     (width 'integer)
     (height 'integer)
     (default-expr 'expression))
  (rect-file
   (string path)
   width height
   default-expr))

(define-map-editor-command (com-horizontal-cat :name t)
    ((file1 'symbol)
     (file2 'symbol)
     (fileout 'symbol)
     (start2 'integer :default 0)
     (stop2 '(or null integer) :default nil))
  (horizontal-cat (string file1)
		  (string file2)
		  (string fileout)
		  :start2 start2
		  :stop2 stop2))

(define-map-editor-command (com-vertical-cat :name t)
    ((file1 'symbol)
     (file2 'symbol)
     (fileout 'symbol)
     (start1 'integer :default 0)
     (stop1 '(or null integer) :default nil)
     (start2 'integer :default 0)
     (stop2 '(or null integer) :default nil))
  (vertical-cat (string file1)
		(string file2)
		(string fileout)
		:start1 start1
		:stop1 stop1
		:start2 start2
		:stop2 stop2))

(define-map-editor-command (com-extract-rect :name t)
    ((filein 'symbol)
     (fileout 'symbol)
     (x 'integer)
     (xlim 'integer)
     (y 'integer)
     (ylim 'integer))
  (extract-rect (string filein)
		(string fileout)
		y
		ylim
		x
		xlim))

(define-map-editor-command (com-clobber-rect :name t)
    ((filein1 'symbol)
     (filein2 'symbol)
     (fileout 'symbol)
     (x 'integer)
     (y 'integer)
     (width 'integer)
     (height 'integer))
  (clobber-rect (string filein1)
		(string filein2)
		(string fileout)
		y
		(+ y height)
		x
		(+ x width)))

(define-map-editor-command (com-change-map :name t)
    ((file 'symbol))
  (with-slots
	(table-list)
      *application-frame*
    (let
	((lists
	   (with-open-file
	       (in (string file))
	     (loop
	       :collect (handler-case
			    (read-delimited-list
			     #\newline in)
			  (end-of-file (e)
			    (declare (ignore e))
			    (return lists)))
		 :into lists))))
      (setf table-list lists))))

(define-map-editor-command (com-cat :name t)
    ((path 'symbol))
  (let ((*standard-output* *terminal-io*))
    (cat (string path))))

(define-map-editor-command (com-chdir :name t)
    ((dir 'symbol))
  (print (uiop:chdir (string dir))
	 *terminal-io*))

(define-map-editor-command (com-mkdir :name t)
    ((dir 'symbol))
  (print (ensure-directories-exist (string dir))
	 *terminal-io*))

(define-map-editor-command (com-writef :name t)
    ((path 'symbol))
  (let ((*print-pretty* nil))
    (with-open-file (*standard-output*
		     (string path)
		     :direction :output
		     :if-exists :supersede
		     :if-does-not-exist :create)
      (with-slots
	    (table-list)
	  *application-frame*
	(format
	 t
	 "~{~{~s~^	~}~%~}"
	 table-list)))))


;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;; VERSION TWO ⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇
;;;;⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇⌇

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Feature A: execute-list≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-execute-list :name t :keystroke (#\B :meta))
    ()
  (let ((frame *application-frame*))
    (with-slots
	  (cur1)
	frame
      (dolist
	  (command cur1)
	(execute-frame-command frame command)))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision B: lisp commands≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

;; funcall

(define-map-editor-command (com-funcall :name t :keystroke (#\Q :meta))
    ()
  (with-slots
	(cur1 cur2 table-list cursor-locn)
      *application-frame*
    (setf cur2
	  (funcall cur1
		   (nth (cadr cursor-locn) 
			(nth (car cursor-locn)
			     table-list))))))

;; apply
(define-map-editor-command (com-apply :name t :keystroke (#\W :meta))
    ()
  (with-slots
	(cur1 table-list cursor-locn)
      *application-frame*
    (setf cur1
	  (apply cur1
		 (nth (cadr cursor-locn) 
		      (nth (car cursor-locn)
			   table-list))))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision C: player's plist≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-gets :name t :keystroke (#\E :meta))
    ()
  (with-slots
	(cur1 player)
      *application-frame*
    (setf cur1 (get player cur1))))

(define-map-editor-command (com-setsgets :name t :keystroke (#\R :meta))
    ()
  (with-slots
	(cur1 cur2 player)
      *application-frame*
    (setf (get player cur2) cur1)))

;; change-player
(defmethod change-player ((obj map-editor)
			  (new-player symbol))
  (with-slots
	(player cur1 cur2 cursor-locn)
      obj
    (let ((new-cur1 (get new-player :last-cur1))
	  (new-cur2 (get new-player :last-cur2))
	  (new-x (or (get new-player :last-x) 0))
	  (new-y (or (get new-player :last-y) 0)))
      (psetf player new-player
	     cur1 new-cur1
	     cur2 new-cur2
	     cursor-locn (list new-y new-x)))))

;; extract-player
(defmethod extract-player ((obj map-editor))
  (with-slots
	(player cur1 cur2 cursor-locn)
      obj
    (psetf (get player :last-cur1) cur1
	   (get player :last-cur2) cur2
	   (get player :last-x) (cadr cursor-locn)
	   (get player :last-y) (car cursor-locn))
    (list obj player)))

;; com-change-player
(define-map-editor-command (com-change-player :name t  :keystroke (#\T :meta))
    ((to-player 'symbol))
  (change-player
   *application-frame*
   to-player))

;; com-extract-player
(define-map-editor-command (com-extract-player :name t :keystroke (#\A :meta))
    ()
  (with-slots
	(player cur1 cur2 cursor-locn)
      *application-frame*
    (psetf (get player :last-cur1) cur1
	   (get player :last-cur2) cur2
	   (get player :last-x) (cadr cursor-locn)
	   (get player :last-y) (car cursor-locn))
    (setf cur1 player)))
  
;; doas
(defmethod doas ((obj map-editor)
		 player
		 command)
  (prog ((last-player (extract-player *application-frame*)))
     (unwind-protect
	  (progn
	    (change-player *application-frame* player)
	    (execute-frame-command *application-frame*
				   command))
       (apply 'change-player last-player))))

;; com-doas
(define-map-editor-command (com-doas :name t :keystroke (#\S :meta))
    ((player 'symbol)
     (command 'command))
  (doas *application-frame*
	player
	command))

;; doas-list
(defmethod doas-list ((obj map-editor)
		      player
		      list)
  (prog ((last-player (extract-player *application-frame*)))
     (unwind-protect
	  (progn
	    (change-player *application-frame* player)
	    (dolist (command list)
	      (execute-frame-command *application-frame*
				     command)))
       (apply 'change-player last-player))))

;; com-doas-list
(define-map-editor-command (com-doas-list :name t :keystroke (#\D :meta))
    ((player 'symbol)
     (list 'list))
  (doas-list *application-frame*
	     player
	     list))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision D: rect set operations≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

;; rect-union
(defun rect-union
    (file1 file2 fileout)
  (with-open-file (in1 file1)
    (with-open-file (in2 file2)
      (with-open-file (out fileout)
	(handler-case
	    (loop :for row1 := (read-delimited-list #\newline in1)
		  :for row2 := (read-delimited-list #\newline in2) :do
		    (format out "~{~s~^	~}~%"
			    (loop :for cell1 :in row1
				  :for cell2 :in row2
				  :collect (union cell1 cell2))))
	  (end-of-file () t))))))

(define-map-editor-command (com-rect-union :name t :keystroke (#\C :meta))
    ((file1 'symbol) (file2 'symbol) (fileout 'symbol))
  (rect-union (string file1)
	      (string file2)
	      (string fileout)))

;; intersection
(defun rect-intersection
    (file1 file2 fileout)
  (with-open-file (in1 file1)
    (with-open-file (in2 file2)
      (with-open-file (out fileout)
	(handler-case
	    (loop :for row1 := (read-delimited-list #\newline in1)
		  :for row2 := (read-delimited-list #\newline in2) :do
		    (format out "~{~s~^	~}~%"
			    (loop :for cell1 :in row1
				  :for cell2 :in row2
				  :collect (intersection cell1 cell2))))
	  (end-of-file () t))))))

(define-map-editor-command (com-rect-intersection :name t :keystroke (#\Z :meta))
    ((file1 'symbol) (file2 'symbol) (fileout 'symbol))
  (rect-intersection (string file1)
		     (string file2)
		     (string fileout)))

;; difference
(defun rect-difference
    (file1 file2 fileout)
  (with-open-file (in1 file1)
    (with-open-file (in2 file2)
      (with-open-file (out fileout)
	(handler-case
	    (loop :for row1 := (read-delimited-list #\newline in1)
		  :for row2 := (read-delimited-list #\newline in2) :do
		    (format out "~{~s~^	~}~%"
			    (loop :for cell1 :in row1
				  :for cell2 :in row2
				  :collect (set-difference cell1 cell2))))
	  (end-of-file () t))))))

(define-map-editor-command (com-rect-difference :name t :keystroke (#\X :meta))
    ((file1 'symbol) (file2 'symbol) (fileout 'symbol))
  (rect-difference (string file1)
		   (string file2)
		   (string fileout)))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision E: rotatef cur1 mapcell≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defmethod cur1-rotatef ((obj map-editor))
  (with-slots
	(table-list cursor-locn cur1)
      obj
    (rotatef cur1
	     (nth (cadr cursor-locn) 
		  (nth (car cursor-locn)
		       table-list)))))

(define-map-editor-command (com-cur1-rotatef :name t :keystroke (#\F :meta))
    ()
  (cur1-rotatef *application-frame*))
	     
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision F: note location≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defmethod note-location ((obj map-editor))
  (with-slots
	(cur1 cursor-locn)
      obj
    (setf cur1
	  (list :x (cadr cursor-locn)
		:y (car cursor-locn)))))

(define-map-editor-command (com-note-location :name t :keystroke (#\V :meta))
    ()
  (note-location *application-frame*))



;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision G: Add spacetime≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅


(defclass spacetime-box ()
  ((dims :type t :initarg :dims)
   (inward-facets :type t :initarg :inward-facets)
   (times.contentses :type t :initarg :times.contentses)
   (active-time :type t))
  (:documentation "spacetime-box
dims; (width height depth) ; width and height of one layer, depth is the number of layers.
inward-facets; (((x-min x-max) (y-min y-max) (z-min z-max)) (x-offset y-offset z-offset) spacetime-box)
times.contentses ((0 . (top to bottom layer maps at time zero)) (1 . (top_ to_ bottom_ layer_ maps_ at_ time_ one_)))
"))

(defmethod set-time (spacetime-box new-time)
  "set-time (spacetime-box new-time)
sets the first time in times.contentses to new-time."
  (with-slots
	(times.contentses)
      spacetime-box
    (rplaca (car times.contentses) new-time)))

(defmethod get-source-boxes ((obj spacetime-box) time amount)
  "get-source-boxes (spacetime-box time amount)
creates a hashtable of the 26-connected neighbors provide amount padded cells about this spacetime-box at time time."
  (with-slots
	(inward-facets dims)
      obj
    (flet
	((containsp (xyz bounds)
	   (and (<= (car (first bounds))
		    (first xyz)
		    (cadr (first bounds)))
		(<= (car (second bounds))
		    (second xyz)
		    (cadr (second bounds)))
		(<= (car (third bounds))
		    (third xyz)
		    (cadr (third bounds))))))
      (let ((source-boxes (make-hash-table)))
	(loop :for x :from (- amount) :below (+ (first dims) amount) :do
	  (loop :for y :from (- amount) :below (+ (second dims) amount) :do
	    (loop :for z :from (- amount) :below (+ (third dims) amount)
		  :for xyzt := (list x y z time)
		  :for facet := (assoc xyzt inward-facets :test #'containsp)
		  :for facet-box := (third facet)
		  :for timep := (with-slots
				      (times.contentses)
				    facet-box
				  (assoc time times.contentses))
		  :when (and facet timep) :do
		    (setf (gethash (third facet) source-boxes)
			  (nconc
			   (list (cons xyzt facet))
			   (gethash (third facet) source-boxes))))))
	source-boxes))))

(defun boxes-to-mapnames (by-boxes-hash)
  "boxes-to-mapnames
expects the results of get-source-boxes, and produces a hashtable keyed by the files (i.e. symbols) providing each ~voxel"
  (loop
    :with by-mapnames := (make-hash-table)
    :for key :being :the :hash-keys :in by-boxes-hash
      :using (:hash-value val) :do
	(loop
	  :for record :in val
	  :for xyzt := (first record)
	  :for (x y z time) := xyzt
	  :for bounds := (second record)
	  :for offsets := (third record)
	  :for (x-offset y-offset z-offset) := offsets
	  :for box := (fourth record)
	  :for right-time := (with-slots
				   (times.contentses)
				 box
			       (cdr (assoc time times.contentses)))
	  :for right-place := (nth (+ z z-offset) right-time)
	  :do
	     (setf (gethash right-place by-mapnames)
		   (nconc
		    (list record)
		    (gethash right-place by-mapnames))))
    :finally (return by-mapnames)))

(defun by-mapnames-to-pieces (by-mapnames)
  "by-mapnames-to-pieces
consumes the hash-table from boxes-to-mapnames, and produces a sorted list of tagged sequences spanning the original get-source-boxes."
  (loop
    :for key :being :the :hash-keys :in by-mapnames
      :using (:hash-value vals)
    :for ranges
      := (loop :initially (sort vals '< :key 'caar)
			  (stable-sort vals '< :key 'cadar)
			  (stable-sort vals '< :key 'caddar)
	       :with rows := (list)
	       :for lastrow := nil :then (last rows)
	       :for (lx ly lz ltime) := (cadar (last lastrow))
	       :for record :in vals
	       :for (xyzt bounds offset box) := record
	       :for (x y z time) := xyzt
	       :for (x-o y-o z-o) := offset
	       :for x+ := (+ x-o x)
	       :for y+ := (+ y-o y)
	       :for z+ := (+ z-o z)
	       :if (equal (list x+ y+ z) (list lx ly lz))
		 :do (incf (caadar lastrow)) :else :do
		   (setf rows (nconc rows (list (list (list x+ y+ z) (list (1+ x+) y+ z)))))
	       :finally (return rows))
    :for path := (string key)
    :for pieces := (loop :initially (print path)
			 :with map := (with-open-file
					  (in path)
					(loop :collecting
					      (handler-case (read-delimited-list #\newline in)
						(end-of-file (e) (return sequences)))
						:into sequences))
			 :for range :in ranges
			 :for (from to) := range
			 :for (from-x from-y from-z) := from
			 :for (to-x to-y to-z) := to
			 :collecting (list from (subseq (nth from-y map) from-x to-x)))
    :nconc pieces :into all-pieces
    :finally (return all-pieces)))

(defun jiggle (list symbol x y)
  (loop :for l :in list
	:for symbolp := (equal (caaadr l) symbol)
	:when symbolp :do
	  (incf (caar l) x)
	  (incf (cadar l) y))
  list)

(defun really-sort (pieces)
  (setf pieces (sort pieces '> :key 'caar))
  (setf pieces (stable-sort pieces '> :key 'cadar))
  (setf pieces (stable-sort pieces '> :key 'caddar)))


(defun split-by-level
    (list)
  (loop
    :with splits := (list)
    :for l :in list
    :for last-z := nil :then z
    :for z := (caddar l)
    :unless (equal last-z z) :do
      (push (list l) splits)
    :else :do
      (push l (car splits))
    :finally
       (return (loop :for split :in splits
		     :collect
		     (loop :for lastline := nil :then line
			   :for line :in split
			   :for lastpos := (car lastline)
			   :for lastrest := (cadr lastline)
			   :for pos := (car line)
			   :for rest := (cadr line)
			   :if (equal (cadr lastpos) (cadr pos))
			     :do (setf (cadr lastline)
				       (nconc (cadr lastline) (cadr line))
				       line lastline)
			   :else :if lastline
				   :collect lastline
				     :into results
			   :finally
			      (return
				(nconc results (list line))))))))

(defmethod load-active-time ((obj spacetime-box) time distance)
  (let* ((source-boxes (get-source-boxes obj time distance))
	 (mapnames (boxes-to-mapnames source-boxes))
	 (pieces (by-mapnames-to-pieces mapnames)))
    (with-slots (active-time) obj
      (setf active-time 
	    (split-by-level pieces)))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision H: Render/cache≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defvar *pattern-cache* (make-hash-table))

(defun empty-pattern-cache ()
  (setf *pattern-cache* (make-hash-table)))

(defun maybe-render-bitmap (symbol &optional (stream t))
  (when (get symbol :bitmap)
    (unless (gethash (get symbol :bitmap) *pattern-cache*)
      (setf (gethash (get symbol :bitmap) *pattern-cache*)
	    (make-pattern-from-bitmap-file
	     (string (get symbol :bitmap)))))
    (draw-pattern*
     stream
     (gethash (get symbol :bitmap) *pattern-cache*)
     0 0)
    (values (get symbol :bitmap))))

(define-map-editor-command (com-get-bitmap :name t)
    ()
  (with-slots
	(cur1)
      *application-frame*
    (setf cur1 (get cur1 :bitmap))))

(define-map-editor-command (com-set-bitmap :name t)
    ()
  (with-slots
	(cur1 cur2)
      *application-frame*
    (setf (get cur1 :bitmap)
	  cur2)))
    
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision I: hextille dirs≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(define-map-editor-command (com-jh :name t :keystroke (#\J :control :meta))
    ()
  (let ((frame *application-frame*))
    (execute-frame-command frame '(com-j))
    (execute-frame-command frame '(com-h))))

(define-map-editor-command (com-kl :name t :keystroke (#\K :control :meta))
    ()
  (let ((frame *application-frame*))
    (execute-frame-command frame '(com-k))
    (execute-frame-command frame '(com-l))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision J: directory com≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defun directory-to-cur1 (filespec)
  (with-slots
	(cur1)
      *application-frame*
    (setf cur1 (directory filespec))))

(define-map-editor-command (com-directory :name t)
    ((filespec 'string :default "./*.*"))
  (directory-to-cur1 filespec))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision K: com-peek≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defun adjacent-peek (sym &optional (map-editor *application-frame*))
  (with-slots (table-list cursor-locn) map-editor
    (destructuring-bind (y x) cursor-locn
      (case sym
	(w (decf x))
	(h (decf x))
	(e (incf x))
	(l (incf x))
	(nw (decf y))
	(k (decf y))
	(ne (decf y) (incf x))
	(kl (decf y) (incf x))
	(sw (incf y) (decf x))
	(jh (incf y) (decf x))
	(se (incf y))
	(j (incf y)))
      (nth y (nth x table-list)))))

(define-map-editor-command (com-peek :name t)
    ((sym '(completion (w h e l nw jh ne j sw k se kl))))
  (with-slots (cur1) *application-frame*
    (setf cur1 (adjacent-peek sym))))

;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;; Revision L: select≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅
;;;≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅≅

(defvar *selection* '())
(defvar *selection-xys* '())

(defmethod select ((obj map-editor))
  (with-slots (table-list cursor-locn) obj
    (push (copy-tree
	   (nth (cadr cursor-locn)
		(nth (car cursor-locn)
		     table-list)))
	  *selection*)
    (push (copy-list cursor-locn)
	  *selection-xys*)))

(defun deselect ()
  (setf *selection* (list)
	*selection-xys* (list)))

(define-map-editor-command (com-select :name t :keystroke (#\= :meta))
    ()
  (select *application-frame*))

(define-map-editor-command (com-deselect :name t :keystroke (#\_ :meta))
    ()
  (deselect))