;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  TARGET TILING GAME
;;;     written by Glenn A. Iba
;;;
;;;    Copyright (c) 2008 by Glenn A. Iba
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;  This code runs in LispWorks
;;;     A free demo edition (called "LispWorks Personal Edition")
;;;     is available from http://www.lispworks.com/
;;;     LispWorks Personal Edition is available for:
;;;           MacOSX
;;;           Windows
;;;           Linux
;;;           FreeBSD
;;;     This code has been run successfully on MacOSX and Windows.
;;;     I have not heard reports of success with Linux or FreeBSD

;;;  Also, now includes (all in this 1 file) these support files:
;;;     mygraphics2.lisp
;;;     mygui.lisp
;;;     grid-editor-3d.lisp  (appears at end)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Release Notes
;;;   Rel-1a
;;;      Modified so Start Game resets "Lines Clearing" Stat
;;;      Modified TakeBack mechanism to store and restore **total-lines-cleared**
;;;           (in order to properly count lines cleared for dynamic tiling)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  MY GRAPHICS   ( mygraphics2.lisp )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Quick and dirty Quickdraw
;    Fails to handle multiple window states
(defparameter **font-size** 14)
(defparameter **font-family** "Monaco")
(defparameter **font-weight** :regular)
(defparameter **foreground-color** :black)
(defparameter **window-cursor-x** 0)
(defparameter **window-cursor-y** 0)
; implement param for pen-size, ie line thickness ??

(defun window-select (win)
  (select-window win))

(defun move-to (window x y)
  (setf **window-cursor-x** x
        **window-cursor-y** y))

(defun line-to (window x y)
  (draw-line window
             **window-cursor-x**
             **window-cursor-y**
             x
             y)
  (move-to window x y))

(defun set-pen-size (window pen-size)
  (gp:set-graphics-state window :thickness pen-size))


;; the following sets the font IMPLICITLY (by setf'ing globals)
(defun set-view-font (window font-spec) ;font-spec eg. ("Helvetica" 20 :bold)
  (setf **font-family** (first font-spec)
        **font-size** (second font-spec)
        **font-weight** (case (third font-spec)
                          (:bold :bold)
                          (t :regular))))

;; this directly modifies the graphic state of window via capi calls
(defun set-view-font-explicitly (window font-spec)
  (let ((font-family (first font-spec))
        (font-size (second font-spec))
        (font-weight (case (third font-spec)
                       (:bold :bold)
                       (:normal :regular)
                       (t :regular))))
    (gp:set-graphics-state window
                           :font
                           (gp:find-best-font window
                                              (gp:make-font-description 
                                               :family font-family
                                               :size font-size
                                               :weight font-weight)))))

(defun set-fore-color (window color)
  (setf **foreground-color** color)
  (gp:set-graphics-state window :foreground color))

(defun choose-file-dialog (&optional (message "choose a file"))
  (capi:prompt-for-file message))

(defun get-string-from-user (&optional (message "Enter a string"))
  (capi:prompt-for-string message))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro win-format-old (window format-string &rest format-args)
  `(draw-string ,window 
                (format nil ,format-string ,@format-args)
                **window-cursor-x**
                **window-cursor-y**))

(defmacro win-format (window format-string &rest format-args)
  `(capi:apply-in-pane-process
    ,window
    'draw-string 
    ,window 
    (format nil ,format-string ,@format-args)
    **window-cursor-x**
    **window-cursor-y**
    :font-size **font-size**
    :font-family **font-family**
    :font-weight **font-weight**
    :color **foreground-color**))

; Create a font specification
(defun make-font-spec (&key (family "monaco")
                            (size 20))
      (gp:make-font-description
       :family family
       :size size))

; Create an output-pane
(defun make-window (&optional (width 400)(height 400)(title "My Window")
                              (best-x 100) (best-y 100)
                              input-model)
  (capi::contain
   (make-instance 'capi::output-pane
                  :input-model input-model)
   :best-width width
   :best-height height
   :title title
   :best-x best-x
   :best-y best-y))

(defun set-window-title (window title-string)
  (setf (capi:interface-title (capi:element-interface window))
        title-string))

; Clear window
(defun clear-window (window &optional (sleep-period 0.1))
  (capi:apply-in-pane-process
   window
   'gp:clear-graphics-port window)
  (sleep sleep-period))

; Showing, hiding, "selecting" windows
(defun hide-window (win &optional iconify?)
  (capi:hide-interface win iconify?))

; This doesn't bring to front, use select-window for that
(defun show-window (win)
  (capi:show-interface win))

;; bring window to front (doesn't set focus)
(defun select-window (win)
;  (hide-window win)
;  (show-window win)
  (capi:raise-interface win))

(defun window-close (win) ; alias function
  (close-window win))

(defun close-window (win)
  (capi:quit-interface win))

(defun find-window (title-string)
  (loop for interface in (capi:screen-interfaces **cocoa-screen**)
        when
        (string-equal title-string
                      (capi:interface-title interface))
        do
        (return interface)))

(defparameter **cocoa-screen**
  (let* ((temp-win (make-window))
         (screen (capi:convert-to-screen temp-win)))
    (close-window temp-win)
    screen))

(defun find-listener ()
  (loop for interface in (capi:screen-interfaces **cocoa-screen**)
        when
        (typep interface 'lispworks-tools:listener)
        do
        (return interface)))

(defun activate-listener ()
  (capi:activate-pane (find-listener)))

(defun find-listener-editor-pane ()
  (slot-value (find-listener) 'capi:editor-pane))


; Draw a circle
(defun draw-circle (window center-x center-y radius &key (color **foreground-color**))
  (capi:apply-in-pane-process
   window
   'gp:draw-circle window center-x center-y radius
   :foreground color))

; Draw a filled circle
(defun fill-circle (window center-x center-y radius &key (color **foreground-color**))
  (capi:apply-in-pane-process
   window
   'gp:draw-circle window center-x center-y radius
   :filled t
   :foreground color))

; Draw an arc
(defun draw-arc (window x y width height start-angle sweep-angle 
                        &key (color **foreground-color**))
  (capi:apply-in-pane-process
   window
   'gp:draw-arc window x y width height start-angle sweep-angle
   :foreground color))

;; NOTE THAT GP:DRAW-ARC IS BUGGY! (Fails if start-angle is other than 0)
;;     Works OK for circles, but not ellipses!
; Fill an arc
(defun fill-arc (window x y width height start-angle sweep-angle 
                        &key (color **foreground-color**))
  (capi:apply-in-pane-process
   window
   'gp:draw-arc window x y width height start-angle sweep-angle
   :filled t
   :foreground color))

; Display a text string
(defun draw-string (window string x y
                           &key
                           (font-size **font-size**)
                           (font-family **font-family**)
                           (font-weight **font-weight**)
                           (color **foreground-color**))
  (gp:with-graphics-state (window :font
                                  (gp:find-best-font
                                   window (gp:make-font-description 
                                           :family font-family
                                           :size font-size))
                                  :foreground color)
    (gp:draw-string window string x y)))

(defun draw-centered-string (window string x y
                                    &key
                                    (font-size **font-size**)
                                    (font-family **font-family**)
                                    (font-weight **font-weight**)
                                    (color **foreground-color**))
  (let* ((char-width (ceiling (* 3/5 font-size)))
         (string-width (* (length string) char-width))
         (char-descend-height (floor (* 1/5 font-size)))
         (string-base (+ y (floor (- font-size char-descend-height) 2)))
         (string-start (- x (floor string-width 2))))
    (draw-string window string string-start string-base
                 :font-size font-size
                 :font-family font-family
                 :font-weight font-weight
                 :color color)))

;;; Old definition with capi:apply-in-pane-process
; (defun draw-string (window string x y &key (font-size 14) (font-family "Monaco"))
;  (gp:with-graphics-state (window :font
;                                  (gp:find-best-font
;                                   window (gp:make-font-description 
;                                           :family font-family
;                                           :size font-size)))
;    (capi:apply-in-pane-process 
;     window 'gp:draw-string window string x y)))

;; Draw a text string with multiple lines
(defun display-multi-line-string (window string
                                         &key
                                         (font-size **font-size**)
                                         (font-family **font-family**)
                                         (font-weight **font-weight**)
                                         (color **foreground-color**)
                                         (line-spacing (floor (* 3/2 font-size)))
                                         (indent 10)
                                         (start-y line-spacing)
                                         clear-window?)
  (when clear-window?
    (clear-window window))
  (loop for line-str in (break-into-lines string)
        for y from start-y by line-spacing
        do
        (draw-string window line-str indent y
                     :font-size font-size
                     :font-family font-family
                     :font-weight font-weight
                     :color color)))

(defun break-into-lines (string)
  (loop with string-w-nl = (force-end-with-newline string)
        with string-length = (length string-w-nl)
        for start = 0 then (1+ next-newline-pos)
        for next-newline-pos = (position #\Newline string-w-nl :start start)
        while (and next-newline-pos
                   (< start string-length))
        collect
        (subseq string-w-nl start next-newline-pos)))

(defun force-end-with-newline (string)
  (if (eql (elt string (1- (length string)))
           #\Newline)
      string
    (format nil "~a~%" string)))

; Draw a line
(defun draw-line (window from-x from-y to-x to-y 
                         &key (color **foreground-color**))
  (capi:apply-in-pane-process 
   window
   'gp:draw-line window from-x from-y to-x to-y :foreground color))

; Draw a rect (using width & height)
(defun draw-rect (window left top width height 
                         &key (color **foreground-color**))
  (capi:apply-in-pane-process window
                              'gp:draw-rectangle
                              window left top width height
                              :foreground color))


; Draw a rect (using points)
(defun draw-rect-pts (window left top right bottom &key (color **foreground-color**))
  (draw-rect window left top (- right left) (- bottom top) :color color))

; Draw a filled rect (using width & height)
(defun fill-rect (window left top width height &key (color **foreground-color**))
  (capi:apply-in-pane-process window
                              'gp:draw-rectangle 
                              window left top width height
                              :filled t
                              :foreground color))

; Draw a filled rect (from points)
(defun fill-rect-pts (window left top right bottom &key (color **foreground-color**))
  (fill-rect window left top (- right left) (- bottom top) :color color))

; Clear a rect (uses width & height)
(defun clear-rect (window left top width height)
  (capi:apply-in-pane-process
   window 'gp:clear-rectangle window top left width height))

; Clear a rect (using points)
(defun clear-rect-pts (window left top right bottom)
  (clear-rect window top left (- right left) (- bottom top)))

(defun draw-poly (window point-list &key filled? closed (color **foreground-color**))
  (capi:apply-in-pane-process
   window 'gp:draw-polygon window point-list
   :filled filled?
   :closed closed
   :foreground color))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Audio
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun beep ()
;  (cocoa:ns-beep)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  MY GUI   ( mygui.lisp )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  GUI functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **gui-item-name-registry** nil)

(defun record-named-gui-item (item name)
  (let ((name-pair (assoc name **gui-item-name-registry**)))
    (cond (name-pair
           (setf (second name-pair)
                 item))
          (t (push (list name item)
                   **gui-item-name-registry**)))))

(defun find-named-gui-item (name)
  (second (assoc name **gui-item-name-registry**)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Quickdraw equivalents for backward compatibility
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun view-named (name &optional view)
  (find-named-gui-item name))

(defun dialog-item-text (text-box)
  (get-text-box-text text-box))

(defun set-dialog-item-text (text-box string)
  (set-text-box-text text-box string))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Layouts and containers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This next is to provide lines to visually gauge coordinates when making laying out pinboard
(defun draw-helper-grid-lines (window width height spacing)
  (loop for x from 0 to width by spacing
        do
        (draw-line window x 0 x height))
  (loop for y from 0 to height by spacing
        do
        (draw-line window 0 y width y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Static Text Items
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-text-item (text-string x y font-size)
  (make-instance 'capi:title-pane
                 :text text-string
                 :font (gp:make-font-description
                        :family "Monaco"
                        :size font-size
                        :weight :bold)
                 :x x
                 :y y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Text boxes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Sample use:
;   (setf my-text-box
;         (create-text-box "Enter integer:" "0"))
;   (capi:contain my-text-box)

(defun create-text-box (title name &optional (x 0) (y 0) (text ""))
  (let ((new-text-box
         (make-instance 'capi:text-input-pane
                 :text text
                 :title title
                 :x x
                 :y y)))
    (record-named-gui-item new-text-box name)
    new-text-box))

(defun get-text-box-text (text-box)
  (capi:text-input-pane-text text-box))

(defun set-text-box-text (text-box new-text)
  (setf (capi:text-input-pane-text text-box)
        new-text))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Option Panes (pull-down menus for dialogs)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-option-pane (title item-list
                                 &optional
                                 (x 0)
                                 (y 0) 
                                 (selection-callback)
                                 (selection-index 0))
  (make-instance
   'capi:option-pane
   :items item-list
   :selection selection-index
   :title title
   :selection-callback selection-callback
   :x x
   :y y))

; Note: these work on the items, not the selection index
(defun get-option-pane-selection (option-pane)
  (capi:choice-selected-item option-pane))

(defun set-option-pane-selection (option-pane item)
  (setf (capi:choice-selected-item option-pane) item))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Push Buttons
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-button (text
                      callback-function ; Note that callback-function can be any form
                      &optional (x 0) (y 0))
  (make-instance 'capi:push-button
                 :text text
                 :callback callback-function
                 :x x
                 :y y))

(defun button-callback (data interface)
  (capi:display-message (format nil "data: ~s , :interface ~s" data interface)))

(defun button-callback-args (&rest args)
  (capi:display-message (format nil "args: ~s" args)))

; callback-type can be one of (or list of any of):
;        :FOCUS           eg. button object (mouse-click?)
;        :DATA            whatever is in :data field of (eg) button
;        :INTERFACE       container object ?
;        :COLLECTION      guessing this is like for radio buttons in a panel?
;        :ITEM            button

; Example of button using data
; (setq button (capi:contain
;              (make-instance 
;               'capi:push-button
;               :text "Press Me"
;               :data :click-me
;               :callback #'(lambda (data interface)
;                             (capi:display-message
;                              "Pressed ~S"
;                              data)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Check Boxes (check-buttons)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-check-box (text callback-function &optional (x 0) (y 0))
  (make-instance 'capi:check-button
                 :selection-callback (list callback-function t)
                 :retract-callback (list callback-function nil)
                 :text text
                 :x x
                 :y y))

(defun check-box-checked? (check-box)
  (capi:button-selected check-box))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **tetris-board** nil)
(defparameter **next-piece-board** nil)
(defparameter **tetris-window** nil)
(defparameter **tetris-listener** nil)
(defparameter **geometry** nil)
(defparameter **piece-types** nil)
(defparameter **deterministic-piece-types?** t)
(defparameter **sequential-piece-type-counter** 0)
(defparameter **largest-piece-type** nil)
(defparameter **legal-movements** nil)
(defparameter **number-of-orientations** nil)
(defparameter **piece-type** nil)
(defparameter **display-next-piece** nil)
(defparameter **next-piece-type** nil)
(defparameter **next-piece-offsets** nil)
(defparameter **next-piece-display-offset** nil)
(defparameter **orientation** nil)
(defparameter **next-orientation** nil)         ; pre-computed array for updating orientation
(defparameter **reflection** nil)
(defparameter **piece-row** nil)
(defparameter **piece-col** nil)
(defparameter **piece-dep** nil)
(defparameter **start-row** nil)
(defparameter **start-col** nil)
(defparameter **start-dep** nil)
(defparameter **ceiling-row** nil)
(defparameter **last-row** nil)
(defparameter **last-col** nil)
(defparameter **last-dep** nil)
(defparameter **fall-count** nil)
(defparameter **fall-threshold** nil)
(defparameter **drop-piece** nil)
(defparameter **no-freeze** nil)
(defparameter **still-have-room** nil)
(defparameter **cell-size** 24)
(defparameter **cell-size-left-shift** 5)
(defparameter **cell-size-up-shift** 10)
(defparameter **piece-cell-lists** nil)
(defparameter **piece-add-lists** nil)
(defparameter **piece-delete-lists** nil)
(defparameter **piece-start-offsets** nil)
(defparameter **piece-sizes** nil)
(defparameter **display-cleared-lines** nil)
(defparameter **total-lines-cleared** 0)
(defparameter **all-2d-piece-types** (append (loop for i from 0 to 10 collect i)
                                             (loop for i from 14 to 30 collect i)))
(defparameter **all-3d-piece-types** (loop for i from 0 to 30 collect i))
(defparameter **target-board** nil)
(defparameter **debug-target-board** nil)
(defparameter **target-height** nil)
(defparameter **target-count** nil)
(defparameter **flash-swap-board** nil)
(defparameter **tetris-training?** nil)

(defparameter **piece-type-from-menu** 6)
(defparameter **piece-count-text-box** nil)
(defparameter **lines-cleared-text-box** nil)
(defparameter **targets-solved-text-box** nil)
(defparameter **targets-solved-count** 0)
(defparameter **piece-count** 0)

(defparameter **level-pop-up-menu** nil)
(defparameter **radio-buttons-1** nil)
(defparameter **pre-defined-level-board-width** 5)
(defparameter **pre-defined-start** nil)
(defparameter **pre-defined-target** nil)
(defparameter **pre-defined-levels-selected-by-radio-button** nil)
(defparameter **pre-defined-levels-width-5** nil)
(defparameter **pre-defined-levels-width-6** nil)
(defparameter **pre-defined-levels-width-7** nil)
(defparameter **level-menu-item-list-width-5** nil)
(defparameter **level-menu-item-list-width-6** nil)
(defparameter **level-menu-item-list-width-7** nil)
(defparameter **selected-pre-defined-levels** nil)
(defparameter **level-number** nil)
(defparameter **last-level** nil)
(defparameter **original-tetris** nil)

(defparameter **demo-mode** nil)

(defparameter **saved-start** nil)
(defparameter **saved-target** nil)
(defparameter **saved-levels** nil)

(defparameter **recording-enabled** nil)
(defparameter **recorded-actions** nil)
(defparameter **recorded-games** nil)

(defparameter **reflection-enabled** nil)

(defparameter **start-grid-click-view** nil)
(defparameter **target-grid-click-view** nil)
(defparameter **use-start-board** nil)
(defparameter **use-target-board** nil)

(defparameter **max-freeze-boards** 1000)
(defparameter **freeze-board-head** 0)
(defparameter **freeze-board-tail** 0)
(defparameter **freeze-board-queue** nil)       	; will be an array
(defparameter **freeze-board-forward-count** 0)

(defparameter **consecutive-full-row-requirement** 1)

;; color names
(defparameter *white-color* :white)
(defparameter *gold-color* :gold)
(defparameter *light-blue-color* :lightblue)
(defparameter *blue-color* :blue)
(defparameter *light-gray-color* :lightgray)
(defparameter *red-color* :red)
(defparameter *yellow-color* :yellow)
(defparameter *green-color* :green)
(defparameter *dark-green-color* :darkgreen)
(defparameter *pink-color* :pink)

(defparameter **key-input-queue** (list 'commands))
(defparameter **tetris-process** nil)
(defparameter **listener-input?** nil)

;(require :quickdraw)
;Instead, need my LW substitute files mygraphics2.lisp and mygui.lisp


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generalized Tetris
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun play-original-tetris (board-height board-width 
		                          &optional
                                          (board-depth 1)
		                          (piece-types '(4 5 6 7 8 9 10))
		                          (level 0)
		                          (start-height 0)
                                          (target-height 0)
                                          (target-count 0)
		                          (geometry 'rectangular)
		                          (new-window? nil)
                                          (cell-size 24))
  (setf **original-tetris** t)
  (play-tetris board-height 
               board-width 
               board-depth
               piece-types
               level 
               start-height
               target-height
               target-count
               geometry
               new-window?
               cell-size))


(defun play-tetris (board-height board-width 
                                 board-depth
		                 &optional
		                 (piece-types '(4 5 6 7 8 9 10))
		                 (level 0)
		                 (start-height 0)
                                 (target-height 0)
                                 (target-count 0)
		                 (geometry 'rectangular)
		                 (new-window? nil)
                                 (cell-size 24))
  (progn
    (tetris-init board-height
	         board-width
                 board-depth
	         piece-types
	         level
	         start-height
	         geometry
	         new-window?
                 cell-size)
    (target-init target-height target-count)
    (set-game-status 'running)
    (tetris-redisplay nil t)
    (tetris-loop)))

(defun play-sequence-tetris (board-width board-depth piece-list fill-height)
  (setf **piece-type-from-menu** piece-list)
  (play-tetris 20 board-width board-depth piece-list 0 fill-height))

(defun tetris-init (board-height board-width 
                                 board-depth
		                 &optional
		                 (piece-types '(4 5 6 7 8 9 10))
		                 (level 0)
		                 (start-height 0)
		                 (geometry 'rectangular)
		                 (new-window? nil)
		                 (cell-size 24))
  (setf **demo-mode** nil)
  (setf **piece-count** 0)
  (setf **sequential-piece-type-counter** -1)
  (setf **total-lines-cleared** 0)
  (display-piece-count)
  (display-cleared-lines)
  (setq **cell-size** cell-size)
  (setq **largest-piece-type** (loop for piece in piece-types maximize piece))
  (setq **fall-threshold** 500
        **drop-piece** nil
        **no-freeze** nil
	**still-have-room** t
	**display-cleared-lines** t)
  (unless (boundp '**total-lines-cleared**)
    (setf **total-lines-cleared** 0))
  (display-cleared-lines)
  (setq **geometry** geometry)
  (process-geometry)
  (setq **piece-types** piece-types)
  (setq **ceiling-row** (max-piece-height piece-types))
  (setq **start-row** **ceiling-row**
	**last-row** (+ board-height **ceiling-row**)
	**last-col** board-width
        **last-dep** board-depth
	**start-col** (1+ (floor (/ board-width 2)))
        **start-dep** (1+ (floor (/ board-depth 2))))
  (setq **tetris-board** (make-array (list (+ 2 **last-row**)
					   (+ 2 **last-col**)
                                           (+ 2 **last-dep**))
                                     :initial-element nil))
  (unless (and **freeze-board-queue**
               (= (length **freeze-board-queue**) **max-freeze-boards**)
               (equal (array-dimensions **tetris-board**)
                      (array-dimensions (second (aref **freeze-board-queue** 0)))))
    (setf **freeze-board-queue** (make-array **max-freeze-boards**))
    (loop for freeze-board from 0 below **max-freeze-boards**
          do
          (setf (aref **freeze-board-queue** freeze-board)
                (list 0 ; place to store **total-lines-cleared** to support takeback
                      (make-array (array-dimensions **tetris-board**)
                            :initial-element nil)))))
  (setf **freeze-board-head** 0
        **freeze-board-tail** 0
        **freeze-board-forward-count** 0)
  (setf **flash-swap-board** 
        (make-array (array-dimensions **tetris-board**)
                    :initial-element *light-blue-color*))
  (setf **target-board**
        (make-array (array-dimensions **tetris-board**)
                    :initial-element nil))
  (when (or (null **tetris-window**)
            ;(not (find-window "Target Board"))
	    new-window?)
    (setq **tetris-window**
	  (create-tetris-window)))
  (clear-window **tetris-window**)
  (init-3d-graphics  **tetris-window** **cell-size**)
  (draw-tetris-border)
  (process-piece-types)
  (cond (**tetris-training?**)
        ((and **use-start-board**
              **start-grid-click-view**
              (edited-board-parameters-ok? **start-grid-click-view**))
         (install-edited-start))
        (t (fill-to-height start-height)))
  (setq **next-piece-type** (select-piece-type))
  (next-piece-setup **piece-types**)
  (save-takeback-boards)
  (start-new-piece)
  (start-recording-game)
;  (clear-listener-input)
  (tetris-redisplay nil t))

(defun tetris-loop ()
  (loop while **still-have-room**
	do
        (process-input)
        (step-simulator))
  (set-game-status 'game-over))

(defun process-input ()
  (unless **drop-piece**
    (let ((input (get-next-char)))
      (if input
          (perform-action (translate-input input))))))

(defun reset-key-input-queue ()
  (setf **key-input-queue**
        (list 'command)))

(defun tetris-key-callback (self x y char)
  (nconc **key-input-queue** (list char)))

(defun get-next-char ()
  (if **listener-input?**
      (read-char-no-hang)
    (pop (rest **key-input-queue**))))

#|
(defun process-input-alt ()
  (let ((input (kludge-read-input)))
    (if input
	(perform-action (translate-input input)))))

(defun kludge-read-input ()
  (cond ((command-key-p) #\j)
        ((option-key-p) #\k)
        ((control-key-p) #\l)
        ((shift-key-p) #\i)
        ((caps-lock-key-p) (read-char))))
|#

(defun translate-input (input-char)
  (case input-char
    ((#\j #\J #\4) 'left)
    ((#\k #\K #\5) 'back)
    ((#\i #\I #\8) 'forward)
    ((#\l #\L #\6) 'right)
    ((#\u #\U #\7) 'reflect-left-right)
    ((#\*) 'fall-fast)
    ((#\space #\0) 'drop-piece)
    ((#\b #\B) 'drop-piece-but-1)
    ((#\n #\N) 'toggle-next)
    ((#\r #\R) 'redisplay)
    ((#\p #\P #\=) 'pause)
    ((#\Q) 'quit)                       ; Must be Shift-Q (avoid accidental quits!)
    ((#\f #\F) 'faster)
    ((#\w #\W) 'slowdown)               ; mnemonic is "whoa!"
    ((#\t #\T #\-) 'take-back)
    ((#\g #\G #\+) 'go-forward)         ; redo a move that was taken back (opposite of take-back)
    ((#\a #\A) 'fall-forward)
    ((#\z #\Z) 'fall-back)
    ((#\s #\S) 'fall-right)
    ((#\x #\X) 'fall-left)
    ((#\d #\D) 'spin-right)
    ((#\c #\C) 'spin-left)
    ((#\1) 'reveal-1)
    ((#\2) 'reveal-2)
;   (#\backarrow 'left)
;   (#\downarrow 'minus-90)
;    (#\uparrow 'plus-90)
;    (#\forwardarrow 'right)
    ))


(defun process-geometry ()
  (case **geometry** 
    (rectangular
     (setq **number-of-orientations** 48)
     (setq **legal-movements**
           '(up down left right forward back
                fall-forward fall-back fall-right fall-left spin-right spin-left
                reflect-left-right)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Auto fill to given Height
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun fill-to-height (height)
  (if (and **pre-defined-levels-selected-by-radio-button**
           (not **original-tetris**))
      (loop for cell in **pre-defined-start**
            do
            (claim-snapshot-cell cell **piece-type**))
    (loop until (not (row-clear? (- (1+ **last-row**) height)))
          do
          (drop-piece-in-random-position))))

(defun drop-piece-in-random-position ()
  (let* ((piece-type (select-piece-type))
	 (orientation (random **number-of-orientations**))
	 (cell-set (aref **piece-cell-lists** piece-type orientation))
	 (extents (cell-list-extents cell-set))
	 (start-col (random-choose (loop for col from (- (fifth extents))     ; left-extent
                                         to (- **last-col** (second extents))     ; right-extent
					 collect col)))
         (start-dep (random-choose (loop for dep from (- (sixth extents))     ; back-extent
                                         to (- **last-dep** (third extents))      ; forward-extent
					 collect dep)))
	 (start-row (- (fourth extents))))     ; up-extent
    ;    (print (list piece-type orientation start-row start-col start-dep))
    (when (and start-row start-col start-dep)
      (loop for last-set = nil then new-cell-set
	    for new-cell-set = (translate-set cell-set (list start-row start-col start-dep))
            then (move-set new-cell-set 'down)
	    while (cell-set-clear? new-cell-set)
            ;	  do (print new-cell-set)
	    finally
	    (loop for cell in last-set
		  do
	          (claim-cell cell piece-type))))))

(defun random-choose (list)
  (if list
      (nth (random (length list)) list)
    nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Actions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun perform-action (action)
  (case action
    (fall-fast (fall-fast))
    (drop-piece (record-action action)
                (setf **drop-piece** t))
    (drop-piece-but-1 (record-action action)
                      (setf **drop-piece** t
                            **no-freeze** t))
    (quit (setq **still-have-room** nil))
    (pause (pause-until-p-is-typed))
    (toggle-next (toggle-next-display))
    (redisplay (tetris-redisplay nil t))
;    (show-lines (toggle-display-cleared-lines))
    (slowdown (make-speed-slower))
    (faster (make-speed-faster))
    (take-back (take-back-move))
    (go-forward (redo-queued-move))
    (reveal-1 (reveal-row 1))
    (reveal-2 (reveal-row 2))
    ((up down left right forward back
         fall-forward fall-back fall-right fall-left spin-right spin-left
         reflect-left-right minus-90 plus-90)
     (record-action action)
     (move-in-direction (movement-code action)))))



(defun fall-fast ()
  (setq **fall-count** **fall-threshold**))

; returns t or nil as move succeeds or not
(defun move-in-direction (movement-code &optional (redisplay? t))
  (cond ((legal-piece-move? movement-code)
	 (move-piece movement-code)
	 (if (or (rotation? movement-code)		; do here since conditional on success of move
                 (reflection? movement-code))
	     (update-orientation movement-code)
           (update-position movement-code))
         (when redisplay? (tetris-redisplay))
	 t)
	(t nil)))

(defun toggle-next-display ()
  (cond (**display-next-piece**
	 (erase-next-piece)
	 (setq **display-next-piece** nil))
	(t (setq **display-next-piece** t)
	   (draw-next-piece))))

(defun pause-until-p-is-typed ()
  (set-game-status 'paused)
  (loop for input-char = (get-next-char)
	until (or (not **still-have-room**)
                  (eql input-char #\P)
                  (eql input-char #\p)
                  (eql input-char #\Q)
                  (eql input-char #\=))
        do
        (when (eql input-char #\Q)
          (abort-existing-tetris))
        (sleep 0.01))
  (set-game-status 'running))



(defun make-speed-faster ()
  (setf **fall-threshold** (ceiling (* .75 **fall-threshold**))))

(defun make-speed-slower ()
  (setf **fall-threshold** (ceiling (* 1.333 **fall-threshold**))))

(defun take-back-move ()
  (when (> **piece-count** 0)
    (decf **piece-count**)
    (display-piece-count)
    (takeback-piece-type)
    (incf **freeze-board-forward-count**)
    (dequeue-freeze-board)))

(defun redo-queued-move ()
  (when (> **freeze-board-forward-count** 0)
    (decf **freeze-board-forward-count**)
    (incf **piece-count**)
    (display-piece-count)
    ; (redo-piece-type)
    (forward-queue-freeze-board)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Recording and RePlaying Games
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun record-moves-checkbox-action (t-or-nil) ; t = checked, nil = not checked
  (setf **recording-enabled** t-or-nil))

(defun start-recording-game ()
  (when **recording-enabled**
    (when **recorded-actions**
      (push **recorded-actions** **recorded-games**))
    (setf **recorded-actions** 
          (list (record-tetris-init-info)))))

(defun stop-recording-game ()
  (when **recording-enabled**
    (when **recording-enabled**
      (when **recorded-actions**
        (push **recorded-actions** **recorded-games**))
      (setf **recorded-actions** nil))))

(defun reset-recording-button-action ()
  (setf **recorded-actions** nil
        **recorded-games** nil))

(defun record-action (action)
  (when **recording-enabled**
    (push action **recorded-actions**)))

(defun record-tetris-init-info ()
  (list **last-col**       ;; board width
        **last-dep**       ;; board depth
        **piece-types**    ;; list of piece types
        (record-initial-targets)
        (record-initial-starts)))

(defun record-initial-targets ()
  nil)

(defun record-initial-starts ()
  nil)


(defun demo-solution-button-action ()
  (reset-stats-button-action)
  (tetris-init 20
               **pre-defined-level-board-width**
               1
               (if (listp **piece-type-from-menu**)
                   **piece-type-from-menu**
                 (list **piece-type-from-menu**))
               0)
  (target-init 0 0)
  (tetris-redisplay)
  (replay-game (find-recorded-game **piece-type-from-menu**
                                   **last-col**
                                   **level-number**)))

(defun find-recorded-game (piece-type board-width level)
  (nth (1- level)
       (reverse (find-recorded-games-list piece-type board-width))))

(defun find-recorded-games-list (piece-type board-width)
  (case piece-type
    (3                                  ; small-L
     (case board-width
       (5 **width-5-small-L-solutions**)
       (6 **width-6-small-L-solutions**)
       (7 **width-7-small-L-solutions**)
       (t nil)))
    (6                                  ; T piece
     (case board-width
       (5 **width-5-T-solutions**)
       (6 **width-6-T-solutions**)
       (7 **width-7-T-solutions**)
       (t nil)))
    (7                                  ; large-L
     (case board-width
       (5 **width-5-large-L-solutions**)
       (6 **width-6-large-L-solutions**)
       (7 **width-7-large-L-solutions**)
       (t nil)))
    (t nil)))

(defun replay-game (game-record)
  (setf **demo-mode** t)
  (let* ((game-rec (reverse game-record))
         (game-spec (first game-rec))
         (game-moves (rest game-rec)))
    (declare (ignore game-spec))
    (loop for action in game-moves
          do
          ; (read-char)
          (get-next-char)
          (perform-action action)
          (step-simulator)
          (loop while **drop-piece**
                do
                (step-simulator)))
    (format t "~%Game Replay Complete~%")))


(defun copy-3d-array (from-array to-array)
  (when (equal (array-dimensions from-array)
               (array-dimensions to-array))
    (loop for row from 0 below (array-dimension from-array 0)
          do
          (loop for col from 0 below (array-dimension from-array 1)
                do
                (loop for dep from 0 below (array-dimension from-array 2)
                      do
                      (setf (aref to-array row col dep)
                            (aref from-array row col dep)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Freeze Board Queue (for taking back moves)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;  head points at first unused board
;;  tail points at "end" of queue" (oldest board if exists, else same as head if empty)
;;  when head "wraps around" it starts pushing tail ahead 
;;;    (erasing positions once queue is full)


(defun freeze-board-queue-empty? ()
  (= **freeze-board-head**
     **freeze-board-tail**))

(defun enqueue-freeze-board ()
  (setf **freeze-board-forward-count** 0)
  (copy-3d-array **tetris-board** 
                 (second (aref **freeze-board-queue** **freeze-board-head**)))
  (setf (first (aref **freeze-board-queue** **freeze-board-head**))
        **total-lines-cleared**)
  (setf **freeze-board-head**
        (mod (1+ **freeze-board-head**)
             **max-freeze-boards**))
  (when (= **freeze-board-head** **freeze-board-tail**)         ; queue is full
    (setf **freeze-board-tail**                    		; bump tail ahead one board
          (mod (1+ **freeze-board-tail**)
               **max-freeze-boards**))))

(defun dequeue-freeze-board (&optional ignore-empty?)
  (unless (and (freeze-board-queue-empty?)
               (not ignore-empty?))
    (setf **freeze-board-head**
          (mod (1- **freeze-board-head**) **max-freeze-boards**))
    (cond ((freeze-board-queue-empty?)   ;;  at oldest recorded position, can't take back
           (setf **freeze-board-head**
                 (mod (1+ **freeze-board-head**) **max-freeze-boards**)))
          (t    ;;  there IS a position to go take-back to
                (copy-3d-array (second
                                (aref **freeze-board-queue** 
                                      ;;  should be valid position since queue not empty 
                                      (mod (1- **freeze-board-head**) **max-freeze-boards**)))
                               **tetris-board**)
                (setf **total-lines-cleared** 
                      (first (aref **freeze-board-queue** 
                                   (mod (1- **freeze-board-head**) **max-freeze-boards**))))
                (sleep .1)
                (display-cleared-lines)
                (sleep .1)
                (start-new-piece)
                (tetris-redisplay)))))

(defun forward-queue-freeze-board ()    ; like enqueue but moves forward 1 in queue (to "redo" a move)
  (setf **freeze-board-head**           ; since only called when forward-count > 0 should never overflow
        (mod (+ 2 **freeze-board-head**)
             **max-freeze-boards**))
  (dequeue-freeze-board t))             ; t to ignore empty queue (if head = tail before takeback)

; for debugging
(defun display-queue-stats ()
  (format t "~%Head = ~a" **freeze-board-head**)
  (format t "~%Tail = ~a" **freeze-board-tail**)
  (format t "~%Forward count = ~a" **freeze-board-forward-count**))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simulator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun step-simulator ()
  (cond ((or **drop-piece**
             (>= **fall-count** **fall-threshold**))
         (make-piece-fall))
        (t (unless **drop-piece**
             (sleep .01))
           (incf **fall-count**))))

  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Falling Pieces
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun start-new-piece ()
  (if **display-next-piece**
      (erase-next-piece))
  (setq **piece-type** **next-piece-type**
	**next-piece-type** (select-piece-type)
	**orientation** 0
	**piece-row** **start-row**
	**piece-col** **start-col**
        **piece-dep** **start-dep**
	**fall-count** 0)
  (if **display-next-piece**
      (draw-next-piece))
  (let ((start-offset (aref **piece-start-offsets** **piece-type**)))
    (incf **piece-row** (first start-offset))
    (incf **piece-col** (second start-offset))
    (incf **piece-dep** (third start-offset)))
  (loop for cell in (translate-set (aref **piece-cell-lists** 
                                         **piece-type** 
                                         **orientation**)
				   (list **piece-row** **piece-col** **piece-dep**))
	do
        (claim-cell cell **piece-type**)))

(defun select-piece-type ()
  (cond (**deterministic-piece-types?**
         (setf **sequential-piece-type-counter**
               (mod (1+ **sequential-piece-type-counter**)
                    (length **piece-types**)))
         (nth **sequential-piece-type-counter**
              **piece-types**))
        (t 
         (nth (random (length **piece-types**))
              **piece-types**))))

(defun takeback-piece-type ()
  (if **display-next-piece**
      (erase-next-piece))
  (setf **next-piece-type** 
        (nth (mod (- **sequential-piece-type-counter** 2)
                  (length **piece-types**))
             **piece-types**))
  (setf **sequential-piece-type-counter**
        (mod (- **sequential-piece-type-counter** 2)
             (length **piece-types**))))

;;; may not need this (try without)
(defun redo-piece-type ()
  (if **display-next-piece**
      (erase-next-piece))
  (setf **next-piece-type** 
        (nth (mod (+ **sequential-piece-type-counter** 1)
                  (length **piece-types**))
             **piece-types**))
  (setf **sequential-piece-type-counter**
        (mod (+ **sequential-piece-type-counter** 1)
             (length **piece-types**))))

(defun make-piece-fall ()
  (cond ((move-in-direction (movement-code 'down) (not **drop-piece**))
	 (setq **fall-count** 0))
        (**no-freeze**
         (tetris-redisplay)
         (setf **fall-count** 0
               **drop-piece** nil
               **no-freeze** nil))
	(t (freeze-piece)
           (tetris-redisplay)
	   (start-new-piece))))

(defun freeze-piece ()
  (update-piece-count)
  (setf **drop-piece** nil)
  (setf **no-freeze**  nil)
  (eliminate-full-rows)
  (save-takeback-boards)
  (unless (top-of-board-clear?)
    (setq **still-have-room** nil)))

(defun save-takeback-boards ()
  (enqueue-freeze-board))

(defun top-of-board-clear? ()
  (loop for row from **ceiling-row** downto 0
	always (row-clear? row)))

(defun update-piece-count (&optional (delta 1))
  (incf **piece-count** delta)
  (display-piece-count))

(defun display-piece-count ()
  (when **piece-count-text-box**
    (update-text-box **piece-count-text-box**
                     **piece-count**)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Moving Pieces
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Have erase-list and draw-list for each piece, orientation, and movement-type
;  use both for movement and for legality checking
;  
; Movement coding:
;   0 up
;   1 right
;   2 down
;   3 left
;   4 plus-90
;   5 minus-90
;   6 plus-60
;   7 minus-60
;   8 plus-60-alt
;   9 minus-60-alt

(defparameter **number-of-movement-codes** 13)

(defun movement-code (movement-name)
  (case movement-name
    (up 0)
    (down 1)
    (right 2)
    (left 3)
    (forward 4)
    (back 5)
    (fall-forward 6)
    (fall-back 7)
    ((fall-right plus-90) 8)
    ((fall-left minus-90) 9)
    (spin-right 10)
    (spin-left 11)
    (reflect-left-right 12)))

(defun movement-name-from-code (movement-code)
  (case movement-code
    (0 'up)
    (1 'down)
    (2 'right)
    (3 'left)
    (4 'forward)
    (5 'back)
    (6 'fall-forward)
    (7 'fall-back)
    (8 'fall-right)
    (9 'fall-left)
    (10 'spin-right)
    (11 'spin-left)
    (12 'reflect-left-right)))

(defun rotation? (movement-code)
  (member movement-code '(6 7 8 9 10 11)))

(defun reflection? (movement-code)
  (member movement-code '(12)))

(defun movement-code-from-orientation (orientation)
  (case **geometry**
    (rectangular orientation)
    (hexagonal (nth orientation '(0 1 12 2 3 10)))
    (hexagonal-alt (nth orientation '(0 11 1 2 13 3)))))

(defun positive-unit-rotation-name ()
  (case **geometry**
    (rectangular 'plus-90)
    (hexagonal 'plus-60)
    (hexagonal-alt 'plus-60-alt)))

(defun update-orientation (movement-code)
  (setf **orientation**
        (aref **next-orientation** **orientation** movement-code)))

(defun update-position (movement-code)
  (let ((displacement (displacement-from-movement-code movement-code)))
    (incf **piece-row** (first displacement))
    (incf **piece-col** (second displacement))
    (incf **piece-dep** (third displacement))))

(defun displacement-from-movement-code (movement-code)
  (case movement-code
    (0 '(-1 0 0))                       ; up
    (1 '(1 0 0))                        ; down
    (2 '(0 1 0))                        ; right
    (3 '(0 -1 0))                       ; left
    (4 '(0 0 1))                        ; forward
    (5 '(0 0 -1))))                     ; back

(defun legal-piece-move? (movement-code
			  &optional
			  (piece-type **piece-type**)
			  (piece-orientation **orientation**))
  (and (or (not (reflection? movement-code))
           **reflection-enabled**)
       (cell-set-clear?
        (translate-set (aref **piece-add-lists** 
                             piece-type
                             piece-orientation
                             movement-code)
		       (list **piece-row** **piece-col** **piece-dep**)))))

(defun cell-set-clear? (cell-list)
  (loop for cell in cell-list
	always (and (array-in-bounds-p **tetris-board** (car cell)(cadr cell)(caddr cell))
                    (not (aref **tetris-board** (car cell)(cadr cell)(caddr cell))))))

(defun move-piece (movement-code
		   &optional
		   (piece-type **piece-type**)
		   (piece-orientation **orientation**)
		   (offset (list **piece-row** **piece-col** **piece-dep**)))
  (let ((add-list (translate-set (aref **piece-add-lists**
				       piece-type
				       piece-orientation
				       movement-code)
				 offset))
	(delete-list (translate-set (aref **piece-delete-lists**
					  piece-type
					  piece-orientation
					  movement-code)
				    offset)))
    (loop for cell in delete-list
	  do (clear-cell (first cell)(second cell)(third cell)))
    (loop for cell in add-list
	  do (claim-cell cell piece-type))))

(defun enable-piece-reflection-checkbox-action (t-or-nil)
  (setf **reflection-enabled** t-or-nil))

(defun beginners-training-checkbox-action (t-or-nil)
  (setf **tetris-training?** t-or-nil))

(defun use-start-board-checkbox-action (t-or-nil)
  (setf **use-start-board** t-or-nil))

(defun use-target-board-checkbox-action (t-or-nil)
  (setf **use-target-board** t-or-nil))

(defun random-next-piece-checkbox-action (t-or-nil)
  (setf **deterministic-piece-types?** (not t-or-nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Game Status Display
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **game-status** nil)

(defun set-game-status (new-status)
  (setf **game-status** new-status)
  (display-game-status))

(defun display-game-status ()
  (when (and **tetris-window**
             (integerp **last-col**))
    (let ((status-string (case **game-status**
                           (paused "     Paused")
                           (running "")  ; flickers with every redisplay
                           (game-aborted "     Game Aborted")
                           (game-over "     Game Over")
                           (solved "Solved! Congratulations")
                           (t "    No Status Set"))))
      (erase-status-area)
      (move-to **tetris-window** 
               (* **cell-size** (+ 3 **last-col**))
               (* **cell-size** 10))
      (set-view-font **tetris-window** '("Monaco" 20 :BOLD))
      (set-fore-color **tetris-window** :black)
;      (sleep .2)
      (win-format **tetris-window** status-string))))

(defun erase-status-area ()
  (fill-rect  **tetris-window**
             (* **cell-size** (+ 3 **last-col**))
             (* **cell-size** 8)
             300
             500
             :color *white-color*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Rotational Vector Geometry
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *r* '(1 0 0))
(defparameter *-r* '(-1 0 0))
(defparameter *c* '(0 1 0))
(defparameter *-c* '(0 -1 0))
(defparameter *d* '(0 0 1))
(defparameter *-d* '(0 0 -1))
(defparameter *r-choice* (list *r* *-r*))
(defparameter *c-choice* (list *c* *-c*))
(defparameter *d-choice* (list *d* *-d*))

(defparameter **all-orientations** nil)
(defparameter **orientation-from-number** nil)

(defun init-all-orientations ()
  (setf **all-orientations**
        (loop for basis-perm in (list (list *r-choice* *c-choice* *d-choice*)
                                      (list *r-choice* *d-choice* *c-choice*)
                                      (list *c-choice* *r-choice* *d-choice*)
                                      (list *c-choice* *d-choice* *r-choice*)
                                      (list *d-choice* *r-choice* *c-choice*)
                                      (list *d-choice* *c-choice* *r-choice*))
              append
              (collect-all-choices basis-perm)))
  (setf **orientation-from-number**
        (make-array (length **all-orientations**)))
  (loop for i from 0
        for orientation in **all-orientations**
        do
        (setf (aref **orientation-from-number** i)
              orientation))
  (setf **next-orientation** (make-array (list **number-of-orientations**
                                               **number-of-movement-codes**)))
  (loop for orient-num from 0 below **number-of-orientations**
        do
        (loop for move in **legal-movements**
              for move-code = (movement-code move)
              do
              (setf (aref **next-orientation** orient-num move-code)
                    (if (or (reflection? move-code)
                            (rotation? move-code))
                        (orient-num-from-basis
                         (basis-transform-set (aref **orientation-from-number** orient-num)
                                              (new-basis-vectors-from-movement-name move)))
                      orient-num)))))

(defun orient-num-from-basis (basis)
  (loop for orient-num from 0 below **number-of-orientations**
        when
        (equal (aref **orientation-from-number** orient-num)
               basis)
        return orient-num
        finally (warn "Failed to find basis in orientation set")))

(defun collect-all-choices (choice-list)
  (cond ((null choice-list)
         (list nil))
        (t
         (loop for choice in (first choice-list)
               append
               (cons-all choice (collect-all-choices (cdr choice-list)))))))

(defun cons-all (item list-of-lists)
  (loop for list in list-of-lists
        collect
        (cons item list)))

(defun new-basis-vectors-from-movement-name (movement-name)
  (case movement-name
    (fall-forward (list *-d* *c* *r*))
    (fall-back (list *d* *c* *-r*))
    (fall-right (list *-c* *r* *d*))
    (fall-left (list *c* *-r* *d*))
    (spin-right (list *r* *-d* *c*))
    (spin-left (list *r* *d* *-c*))
    (reflect-left-right (list *r* *-c* *d*))))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Piece / Shape Specification
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;  Pieces will have:
;     Rotation Point is assumed to be 0 0 (also reference point for specifying position)
;     Offset from starting square
;     Cell list - relative to rotation point
;         Precompute new cell list for each orientation
;     Add / Delete lists for translation and rotation (also used for legality checks)
;     Display Color (gray level)
;

(defun piece-template (template-number)
  (case template-number
    ;; monomino
    (0 '(("X")))
    ;; domino
    (1 '(("Xx")))
    ;; triominoes
    (2 '(("xXx")))
    (3 '(("x "
	  "Xx")))
    ;; 2d tetrominoes
    (4 '(("xXxx")))
    (5 '(("  x"
	  "xXx")))
    (6 '((" x "
	  "xXx")))
    (7 '(("x  "
	  "xXx")))
    (8 '(("Xx"
	  "xx")))
    (9 '(("xX "
	  " xx")))
    (10 '((" Xx"
	   "xx ")))
    ;; 3d tetrominoes
    (11 '(("xX"
           " x")
          (" x"
           "  ")))
    (12 '(("Xx"
           "x ")
          ("  "
           "x ")))
    (13 '(("Xx"
           "x ")
          (" x"
           "  ")))
    ;; 2d pentominoes
    (14 '(("x   "
	   "xXxx")))
    (15 '(("   x"
	   "xxXx")))
    (16 '((" x  "
	   "xXxx")))
    (17 '(("  x "
	   "xxXx")))
    (18 '(("x  "
	   "xXx"
	   "  x")))
    (19 '(("  x"
	   "xXx"
	   "x  ")))
    (20 '(("xx "
	   "xXx")))
    (21 '((" xx"
	   "xXx")))
    (22 '(("x x"
	   "xXx")))
    (23 '(("x  "
	   "xXx"
	   " x ")))
    (24 '(("  x"
	   "xXx"
	   " x ")))
    (25 '(("x  "
	   "xXx"
	   "x  ")))
    (26 '((" x "
	   "xXx"
	   " x ")))
    (27 '(("  xx"
	   "xxX ")))
    (28 '(("xx  "
	   " Xxx")))
    (29 '(("xxx"
	   " .x"
	   "  x")))
    (30 '(("x  "
	   "xX "
	   " xx")))
    (31 '(("xxXxx")))))

(defun cell-list-for-piece-type (type-num)
  (compute-cell-list-from-string-template (piece-template type-num)))

(defun compute-cell-list-from-string-template (string-template)
  (loop with rot-point = nil
        for dep from 0
        for plane in string-template
        append
        (loop for row from 0
	      for row-string in plane
	      append
	      (loop for col from 0 below (length row-string)
		    for char = (elt row-string col)
		    when (or (eql char #\x)
			     (eql char #\X))
		    collect (list row col dep)
		    when (or (eql char #\X)
			     (eql char #\.))
		    do
		    (setq rot-point (list (- row)(- col)(- dep)))))
        into cell-set
	finally
        (return (translate-set cell-set rot-point))))

(defun compute-piece-offset (piece-type)
  (let ((extent-list (piece-extents piece-type)))
    (list (- (first extent-list))
	  (- (ceiling (/ (+ (second extent-list)(fifth extent-list))
			 2)))
          (- (ceiling (/ (+ (third extent-list)(sixth extent-list))
                         2)))
	  )))

(defun max-piece-height (piece-types)
  (loop for piece in piece-types
	maximize (piece-height piece)))

(defun max-piece-width (piece-types)
  (loop for piece in piece-types
	maximize (piece-width piece)))

(defun max-piece-depth (piece-types)
  (loop for piece in piece-types
	maximize (piece-depth piece)))

(defun piece-height (piece-type)
  (let ((piece-extents (piece-extents piece-type)))
    (- (first piece-extents)(fourth piece-extents))))

(defun piece-width (piece-type)
  (let ((piece-extents (piece-extents piece-type)))
    (- (second piece-extents)(fifth piece-extents))))

(defun piece-depth (piece-type)
  (let ((piece-extents (piece-extents piece-type)))
    (- (third piece-extents)(sixth piece-extents))))

(defun piece-extents (piece-type)
  (cell-list-extents (cell-list-for-piece-type piece-type)))

(defun cell-list-extents (cell-list)
  (loop for cell in cell-list
	maximize (first cell) into down-offset
	maximize (second cell) into right-offset
        maximize (third cell) into forward-offset
	minimize (first cell) into up-offset
	minimize (second cell) into left-offset
        minimize (third cell) into back-offset
	finally
        (return (list down-offset right-offset forward-offset up-offset left-offset back-offset))))

(defun next-piece-setup (piece-types)
  (setq **next-piece-board** (make-array (list (+ (max-piece-height piece-types) 2)
					       (+ (max-piece-width piece-types) 2)
                                               (+ (max-piece-depth piece-types) 2)))
	**next-piece-offsets** (make-array (1+ (loop for piece in piece-types
                                                     maximize piece)))
	**next-piece-display-offset** (list 1 (+ **last-col** 5) 1)
	**display-next-piece** nil)
  (loop for piece-type in piece-types
	for extents = (piece-extents piece-type)
	do
        (setf (aref **next-piece-offsets** piece-type)
              (list (- (fourth extents))           ; up-extent
                    (- (fifth extents))            ; left-extent
                    (- (sixth extents))))))        ; back-extent

(defun process-piece-types ()
  (init-all-orientations)
  (setq **piece-cell-lists** (make-array (list (1+ **largest-piece-type**)
					       **number-of-orientations**))
	**piece-add-lists** (make-array (list (1+ **largest-piece-type**) 
                                              **number-of-orientations**
                                              **number-of-movement-codes**))
	**piece-delete-lists** (make-array (list (1+ **largest-piece-type**) 
                                                 **number-of-orientations**
                                                 **number-of-movement-codes**))
	**piece-start-offsets** (make-array (1+ **largest-piece-type**))
        **piece-sizes** (make-array (1+ **largest-piece-type**)))
  (loop for piece-type in **piece-types**
        for piece-cell-list = (cell-list-for-piece-type piece-type)
	do
        (setf (aref **piece-sizes** piece-type)
              (length piece-cell-list))
        (loop for orient from 0 below **number-of-orientations**
              for oriented-cell-set = (basis-transform-set piece-cell-list
                                                           (aref **orientation-from-number** orient))
              do
              (setf (aref **piece-cell-lists** piece-type orient)
                    (sort-for-display oriented-cell-set))
              (loop for movement-name in **legal-movements**
                    for move-code = (movement-code movement-name)
                    for new-set = (move-set oriented-cell-set movement-name)
                    for add-del-pair = (make-add-delete-lists oriented-cell-set new-set)
                    do
                    (setf (aref **piece-add-lists** piece-type orient move-code)
                          (first add-del-pair))
                    (setf (aref **piece-delete-lists** piece-type orient move-code)
                          (second add-del-pair))))
        (setf (aref **piece-start-offsets** piece-type)
	      (compute-piece-offset piece-type))))

(defun move-set (triple-set movement-name)
  (case movement-name
    ((up down left right forward back)
     (translate-set triple-set (displacement-from-movement-code
			        (movement-code movement-name))))
    ((fall-forward fall-back fall-right fall-left spin-right spin-left)
     (rotate-set triple-set movement-name))
    ((reflect-left-right)
     (reflect-set triple-set movement-name))))

(defun translate-set (triple-set translation)
  (loop with row-trans = (first translation)
	with col-trans = (second translation)
        with dep-trans = (third translation)
	for triple in triple-set
	collect
        (list (+ (first triple) row-trans)
              (+ (second triple) col-trans)
              (+ (third triple) dep-trans))))

(defun rotate-set (set rotation-type)
  (basis-transform-set set
                       (new-basis-vectors-from-movement-name rotation-type)))

(defun reflect-set (set reflection-type)
  (basis-transform-set set
                       (new-basis-vectors-from-movement-name reflection-type)))

(defun basis-transform-set (triple-set new-basis)
  (loop for triple in triple-set
	collect
	(basis-transform-point triple new-basis)))

(defun basis-transform-point (point new-basis)
  (let ((point-row (first point))
	(point-col (second point))
        (point-dep (third point))
	(row-vector (first new-basis))
	(col-vector (second new-basis))
        (dep-vector (third new-basis)))
    (list (+ (* point-row (car row-vector))
	     (* point-col (car col-vector))
             (* point-dep (car dep-vector)))
	  (+ (* point-row (cadr row-vector))
	     (* point-col (cadr col-vector))
             (* point-dep (cadr dep-vector)))
	  (+ (* point-row (third row-vector))
	     (* point-col (third col-vector))
             (* point-dep (third dep-vector))))))

(defun add-offsets (offset1 offset2)
  (list (+ (car offset1)(car offset2))
	(+ (cadr offset1)(cadr offset2))
        (+ (caddr offset1)(caddr offset2))))

(defun make-add-delete-lists (old-set new-set)
  (let ((add-list (loop for item in new-set
			when (not (member item old-set :test #'equal))
                        collect item))
	(delete-list (loop for item in old-set
			   when (not (member item new-set :test #'equal))
                           collect item)))
    (list add-list delete-list)))

(defun piece-color (piece-type)
  *blue-color*
;  (+ 0.5 (/ piece-type **largest-piece-type** 2))
  )

(defun sort-for-display (cell-list)
  (sort (append cell-list nil) #'greater-vector?))

(defun greater-vector? (vec1 vec2)
  (cond ((or (null vec1)(null vec2)) nil)
	((> (car vec1)(car vec2)) t)
	((> (car vec2)(car vec1)) nil)
	(t (greater-vector? (cdr vec1)(cdr vec2)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Eliminating rows
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun eliminate-full-rows-old ()
  (flash-full-rows)
  (loop with lines-cleared = 0
	for row from **last-row** downto 0
	do
        (cond ((row-filled? row)
               (clear-row row)
               (incf lines-cleared))
              ((> lines-cleared 0)
               (copy-row-down row lines-cleared)))
	finally
        (when (> lines-cleared 0)
          (incf **total-lines-cleared** lines-cleared)
          (display-cleared-lines))
        (check-targets)))

(defun eliminate-full-rows ()
  (flash-full-rows)
  (loop with lines-cleared = 0
        with full-rows-to-clear = (find-full-rows-n **consecutive-full-row-requirement**)
	for  row from **last-row** downto 0
	do
        (cond ((member row full-rows-to-clear)
               (clear-row row)
               (incf lines-cleared))
              ((> lines-cleared 0)
               (copy-row-down row lines-cleared)))
	finally
        (when (> lines-cleared 0)
          (incf **total-lines-cleared** lines-cleared)
          (display-cleared-lines))
        (check-targets)))

(defun flash-full-rows ()
  (flash-rows (find-full-rows-n **consecutive-full-row-requirement**)))

(defun find-full-rows-n (n)
  (let* ((full-rows (find-full-rows))
         (runs-of-full-rows (group-into-runs full-rows))
         (runs-filtered-by-length
          (loop for run in runs-of-full-rows
                when (>= (length run) n)
                collect run)))
    (loop for run in runs-filtered-by-length
          appending run)))

(defun group-into-runs (int-list)
  (loop with current-run = nil
        with all-runs = nil
        for last-int = nil then int
        for int in int-list
        do
        (cond ((or (null last-int)
                   (<= (abs (- int last-int)) 1))
               (push int current-run))
              (t
               (push current-run all-runs)
               (setf current-run (list int))))
        finally
        (when current-run
          (push current-run all-runs))
        (return all-runs)))

(defun find-full-rows ()
  (loop for row from **last-row** downto 0
        when (row-filled? row)
	collect row))

(defun find-first-empty-row ()
  (loop for row from **last-row** downto 0
        when (row-clear? row)
	return row))

(defun flash-rows (row-list &optional (times 2) (sleep-time .05))
  (loop repeat (* 2 times)
        do
        (sleep sleep-time)
        (loop for row in row-list
              do
              (flash-swap-row row))))

(defun flash-swap-row (row)
  (loop for col from 1 to **last-col**
        do
        (loop for dep from 1 to **last-dep**
              do
              (swap-with-flash-array row col dep))))

(defun swap-with-flash-array (row col dep)
  (let ((temp (aref **tetris-board** row col dep)))
    (basic-claim-cell row col dep (aref **flash-swap-board** row col dep) t)
    (setf (aref **flash-swap-board** row col dep)
          temp)))

(defun reveal-row (n)
  (flash-rows (list (min **last-row** (+ (find-first-empty-row) n)))))

(defun row-filled? (row)
  (loop for col from 1 to **last-col**
	always
        (loop for dep from 1 to **last-dep**
              always
              (aref **tetris-board** row col dep))))

(defun row-clear? (row)
  (loop for col from 1 to **last-col**
        always
        (loop for dep from 1 to **last-dep**
	      never (aref **tetris-board** row col dep))))

(defun clear-row (row)
  (loop for col from 1 to **last-col**
	do
        (loop for dep from 1 to **last-dep**
              do
              (clear-cell row col dep))))

(defun copy-row-down (row how-many-rows)
  (loop for col from 1 to **last-col**
	do
        (loop for dep from 1 to **last-dep**
              do
              (basic-claim-cell (+ row how-many-rows)
		                col
                                dep
		                (aref **tetris-board** row col dep))))
  (clear-row row))

(defun clear-cell (row col dep &optional redraw?)
  (let ((contents (aref **tetris-board** row col dep)))
    (when contents
      (setf (aref **tetris-board** row col dep)
	    nil)
      (when redraw?
        (draw-cell row
                   col
                   dep
                   (cell-color row col dep))))))      ; maybe should be *background-color*

(defun claim-cell (cell piece-type)
  (basic-claim-cell (car cell)(cadr cell) (caddr cell)(piece-color piece-type) t))

(defun basic-claim-cell (row col dep contents &optional redraw?)
  (setf (aref **tetris-board** row col dep)
	contents)
  (if (and redraw? contents)
      (draw-cell row col dep
                 (cell-color row col dep))))

;(defun toggle-display-cleared-lines ()
;  (setq **display-cleared-lines**
;	(not **display-cleared-lines**)))

;(defun display-cleared-lines ()
;  (if **display-cleared-lines**
;      (format t "~%Lines cleared = ~a" **total-lines-cleared**)))

(defun display-cleared-lines ()
  (when **lines-cleared-text-box**
    (update-text-box **lines-cleared-text-box**
                     **total-lines-cleared**)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tetris Targets
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun target-init (target-height target-count)
  (setf **target-height** target-height)
  (setf **target-count** target-count)
  (unless (boundp '**targets-solved-count**)
    (setf **targets-solved-count** 0))
  (update-targets-solved-box)
  (if **debug-target-board**
      (setf **target-board** **debug-target-board**)
    (choose-targets)))


(defun choose-targets ()
  (cond (**tetris-training?**
         (choose-training-target))
        ((and **pre-defined-levels-selected-by-radio-button**
              (not **original-tetris**))
         (install-saved-target))
        ((and **use-target-board**
              **target-grid-click-view**
              (edited-board-parameters-ok? **target-grid-click-view**))
         (install-edited-targets))
        (t (choose-random-targets))))

(defun choose-training-target ()
  (let ((tetris-board **tetris-board**))
    (setq **tetris-board** (make-array (list (+ 2 **last-row**)
					     (+ 2 **last-col**)
                                             (+ 2 **last-dep**))
                                       :initial-element nil))
    (draw-tetris-border)
    (loop until (not (row-clear? **last-row**))
          do
          (drop-piece-in-random-position))
    ; copy board to target
    (copy-contents-without-border **tetris-board** **target-board**)
    ; restore tetris board
    (setf **tetris-board** tetris-board)))

(defun copy-contents-without-border (from-board to-board)
  (loop for row from 0 below (1- (array-dimension from-board 0))
        do
        (loop for col from 1 below (1- (array-dimension from-board 1))
              do
              (loop for dep from 1 below (1- (array-dimension from-board 2))
                    do
                    (setf (aref to-board row col dep)
                          (aref from-board row col dep))))))
                    

(defun install-saved-target ()
  (clear-target-board)
  (loop with vertical-offset = (- **ceiling-row** 1)  ;; Same kludge as fill-to-height w/ pre-defined
        for cell in **pre-defined-target**
        do
        (setf (aref **target-board**
                    (+ (first cell) vertical-offset)
                    (second cell)
                    (third cell))
              t)))

(defun install-edited-targets ()
  (clear-target-board)
  (let* ((tetris-window (find-window "Target Tiling 3D Game"))
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (edited-target-grid (3d-grid **target-grid-click-view**))
         (edited-target-height (array-dimension edited-target-grid 0))
         (truncation-offset (max 0 (- board-rows edited-target-height))))
    (loop with vertical-offset = (+ **ceiling-row** 1)
          for row from 0 below (array-dimension edited-target-grid 0)
          do
          (loop for col from 0 below (array-dimension edited-target-grid 1)
                do
                (loop for dep from 0 below (array-dimension edited-target-grid 2)
                      do
                      (setf (aref **target-board**
                                  (+ row  vertical-offset truncation-offset)
                                  (1+ col)
                                  (1+ dep))
                            (translate-target-value
                             (aref edited-target-grid row col dep))))))
    t))

(defun install-edited-start ()
  (let* ((tetris-window (find-window "Target Tiling 3D Game"))
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (edited-start-grid (3d-grid **start-grid-click-view**))
         (edited-start-height (array-dimension edited-start-grid 0))
         (truncation-offset (max 0 (- board-rows edited-start-height))))
    (loop with vertical-offset = (+ **ceiling-row** 1)
          for row from 0 below (array-dimension edited-start-grid 0)
          do
          (loop for col from 0 below (array-dimension edited-start-grid 1)
                do
                (loop for dep from 0 below (array-dimension edited-start-grid 2)
                      do
                      (setf (aref **tetris-board**
                                  (+ row  vertical-offset truncation-offset)
                                  (1+ col)
                                  (1+ dep))
                            (translate-start-value
                             (aref edited-start-grid row col dep))))))
    t))

(defun translate-target-value (grid-editor-value)
  (case grid-editor-value
    (0 nil)
    (1 t)
    (t (message-dialog (format nil "unexpected grid-editor-value ~a" grid-editor-value)))))

(defun translate-start-value (grid-editor-value)
  (case grid-editor-value
    (0 nil)
    (1 *blue-color*)
    (t (message-dialog (format nil "unexpected grid-editor-value ~a" grid-editor-value)))))

(defun clear-target-board ()
  (loop for row from 0 below (array-dimension **target-board** 0)
        do
        (loop for col from 0 below (array-dimension **target-board** 1)
              do
              (loop for dep from 0 below (array-dimension **target-board** 2)
                    do
                    (setf (aref **target-board** row col dep) nil)))))

(defun choose-random-targets ()
  (let ((row-counts (make-array **target-height**
                                :initial-element 1)))
    (loop with row-area = (* **last-col** **last-dep**)
          repeat (- **target-count** **target-height**)
          do
          (loop for relative-row = (random **target-height**)
                until (< (aref row-counts relative-row) (1- row-area))
                finally
                (incf (aref row-counts relative-row))))
    (loop for relative-row from 0 below **target-height**
          do
          (choose-row-targets (- **last-row** relative-row)
                              (aref row-counts relative-row)))))

(defun choose-row-targets (row num-targets)
  (loop for col from 1 to **last-col**
        do
        (loop for dep from 1 to **last-dep**
              do
              (setf (aref **target-board** row col dep)
                    nil)))
  (loop with target-count = 0
        with max-targets = (min num-targets (1- (* **last-col** **last-dep**)))
        for next-col-try = (1+ (random **last-col**))
        for next-dep-try = (1+ (random **last-dep**))
        while (< target-count max-targets)
        do
        (unless (aref **target-board** row next-col-try next-dep-try)
          (setf (aref **target-board** row next-col-try next-dep-try)
                t)
          (incf target-count))))

(defun check-targets ()
  (when (loop for row from **ceiling-row** to **last-row**
              always
              (loop for col from 1 to **last-col**
                    always
                    (loop for dep from 1 to **last-dep**
                          always
                          (eql (not (aref **tetris-board** row col dep))
                               (not (aref **target-board** row col dep))))))
    ;; target goal is satisfied
    (incf **targets-solved-count**)
    (update-targets-solved-box)
    (loop repeat 5 do (beep)(sleep .3))
    (set-game-status 'solved)
    (tetris-redisplay t)                ; solved? = T
    ;; If demo, quit here
    (when **demo-mode** 
      ;(toplevel)
      )
    (move-to **tetris-window** 
             (* **cell-size** (+ 3 **last-col**))
             (* **cell-size** 12))
    (set-view-font **tetris-window** '("Monaco" 9 :PLAIN))
    (win-format **tetris-window** "Press any key to continue ...")
    (sleep 1)
    (wait-for-char-or-quit)
    (replay-tetris)
    ;;(choose-targets)
    ;;(tetris-redisplay)
    ))

(defun wait-for-char-or-quit ()
  (loop for input-char = (get-next-char)
	until (or input-char
                  (not **still-have-room**))
        do
        (sleep .01)
        finally
        (when (or (not **still-have-room**)
                  (eq input-char #\Q)) ; Shift-Q is quit key
          ;  (toplevel)
          (abort-existing-tetris))))

(defun update-targets-solved-box ()
  (when **targets-solved-text-box**
    (update-text-box **targets-solved-text-box**
                     **targets-solved-count**)))


;;; special debug targets

;;;   x . x x . x
;;;   x . . . . .
;;;   x . x x . x

(defun debug-target-off ()
  (setf **debug-target-board** nil))

(defun debug-target-1 ()
  (setf **debug-target-board**
        (make-array '(23 8) :initial-element nil))
  (loop for target-row-col in '((19 1)(19 3)(19 4)(19 6)(20 1)(21 1)(21 3)(21 4)(21 6))
        for row = (first target-row-col)
        for col = (second target-row-col)
        do
        (setf (aref **debug-target-board** row col) t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Pre-defined levels
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun snapshot-claimed-cells-from-bottom ()
  (loop for row from **last-row** downto 0
        for claimed-cells-this-row = (claimed-cells-in-row row)
        while claimed-cells-this-row
        append claimed-cells-this-row))

(defun claimed-cells-in-row (row)
  (loop for col from 1 to **last-col**
        for cell-value = (aref **tetris-board** row col)
        when cell-value
        collect (list row col)))

;;; Kludge, since level snapshots taken with **ceiling-row** 1,
;;;   but the domino piece uses **ceiling-row** 0
(defun claim-snapshot-cell (cell piece-type)
  (let ((vertical-adjustment (- **ceiling-row** 1)) )
    (basic-claim-cell (+ (car cell) vertical-adjustment)
                      (cadr cell)
                      (caddr cell)
                      (piece-color piece-type))))
        

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; graphics
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun move-listener-window ()
  (loop for listener-window = (find-window "Listener")
        until listener-window
        do (sleep 1)
        finally
        (set-view-position listener-window 550 650))
  (let ((init-window (find-window "Initialization Output")))
    (when init-window
      (window-close init-window))))

(defun close-title-window ()
  (let ((title-window (find-window "Target Tiling Title")))
    (when title-window
      (window-close title-window))))


(defun create-tetris-window ()
  (make-window 500 600 "Target Tiling Board" 20 50
               (if **listener-input?**
                   nil
                 '((:character tetris-key-callback)))))

(defun draw-cell (row col dep
		      &optional
		      (color *blue-color*)
		      (row-offset 0)
		      (col-offset 0)
		      (cell-size  **cell-size**)
		      (window **tetris-window**))
  (let* ((final-row (+ row row-offset))
	 (final-col (+ col col-offset))
         (left (+ (* cell-size final-col) (* (- **last-dep** dep) **cell-size-left-shift**)))
         (top (+ (* cell-size final-row) (* (- **last-dep** dep) **cell-size-up-shift**)))
         (target-color *green-color*))
    (let ((**tetris-window** window))
      (cond ((eql color *pink-color*)   ; target and empty cell
             (draw-translucent-cube-at-x-y left top target-color target-color target-color))
            ((eql color *yellow-color*)         ; target and filled cell
             (draw-cube-at-x-y left top *dark-green-color* *dark-green-color* *dark-green-color*))
            (t
             (draw-cube-at-x-y left top color color color))))))

(defun draw-pre-computed-cell (row col dep
                                   &optional
                                   (color *blue-color*)
                                   (window **tetris-window**)
                                   (frame-color **frame-color**))
  (let* ((**tetris-window** window)
         (translucent? (eql color *pink-color*))
         (final-color (cond ((eql color *pink-color*)   ; target and empty cell
                             *green-color*)
                            ((eql color *yellow-color*)   ; target and filled cell
                             *dark-green-color*)
                            (t color)))
         (poly-list (aref **pre-computed-poly-offset-array** row col dep))
         (top-poly (first poly-list))
         (left-poly (second poly-list))
         (front-poly (third poly-list))
         (back-frame-poly (fourth poly-list)))
    (draw-poly window top-poly :filled? t :color final-color)
    (draw-poly window top-poly :filled? nil :color frame-color)
    (draw-poly window left-poly :filled? t :color final-color)
    (draw-poly window left-poly :filled? nil :color frame-color)
    (draw-poly window front-poly :filled? t :color final-color)
    (draw-poly window front-poly :filled? nil :color frame-color)
    (when translucent?
      (draw-poly window back-frame-poly :filled? nil :color frame-color))))
    

(defun cell-color (row col dep)
  (let ((board-contents (aref **tetris-board** row col dep))
        (target-contents (aref **target-board** row col dep)))
    (if (null target-contents)
        (if board-contents
            board-contents
          *white-color*)                   ; maybe should be background-color
      (if board-contents
          *yellow-color*
        *pink-color*))))

(defun draw-tetris-border (&optional (border-color *red-color*))
  (loop for row from 0 to **last-row**
	do
        (loop for col from 0 to (1+ **last-col**)
              do
              (basic-claim-cell row col 0 border-color)
              (basic-claim-cell row col (1+ **last-dep**) border-color))
        (loop for dep from 1 to **last-dep**
              do
              (basic-claim-cell row 0 dep border-color)
              (basic-claim-cell row (1+ **last-col**) dep border-color)))
  (loop for col from 0 to (1+ **last-col**)
	do
        (loop for dep from 0 to (1+ **last-dep**)
              do
              (basic-claim-cell (1+ **last-row**) col dep border-color))))

(defun draw-next-piece ()
  (when **display-next-piece**
    (loop for cell in (aref **piece-cell-lists** **next-piece-type** 0)
	  for offset = (add-offsets **next-piece-display-offset**
				    (aref **next-piece-offsets** **next-piece-type**))
	  do
          (draw-cell (car cell)
                     (cadr cell)
                     (caddr cell)
                     (piece-color **next-piece-type**)
                     (car offset)
                     (cadr offset)))))

(defun erase-next-piece ()
  (let ((**frame-color** *white-color*))
    (loop for cell in (aref **piece-cell-lists** **next-piece-type** 0)
          for offset = (add-offsets **next-piece-display-offset**
                                    (aref **next-piece-offsets** **next-piece-type**))
          do
          (draw-cell (car cell)
                     (cadr cell)
                     (caddr cell)
                     *white-color*
                     (car offset)
                     (cadr offset)))))

(defun tetris-redisplay (&optional solved? clear?)
  (when clear? (clear-window **tetris-window**))
  (loop for row from (1- (array-dimension **tetris-board** 0)) downto 0
        do
        (loop for col from (1- (array-dimension **tetris-board** 1)) downto 1
              do
              (loop for dep from (1- (array-dimension **tetris-board** 2)) downto 1
                    for color = (aref **tetris-board** row col dep)
                    for target = (aref **target-board** row col dep)
                    do
                    (when (and solved? (not color))
                      ; (draw-cell row col dep (1+ *yellow-color*) 0 0)  ; don't draw 
                      )
                    (when (or color target)
                      (draw-pre-computed-cell row col dep
                                 (if (and target solved?)
                                     *gold-color* ; what was the kludge with (1+ *yellow-color*)?
                                                  ;   it was because *yellow-color* had special meaning
                                   (cell-color row col dep))
                                 )))))
  (draw-next-piece)
  (display-game-status)
  ;(print "tetris-redisplay ")
  ;(window-select *top-listener*)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Perspective Graphics
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **top-poly** nil)
(defparameter **left-poly** nil)
(defparameter **front-poly** nil)
(defparameter **back-frome-poly** nil)
(defparameter **pre-computed-poly-offset-array** nil)
(defparameter **frame-color** *light-gray-color*)

(defun init-3d-graphics (&optional (window **tetris-window**) 
                                   (cell-size **cell-size**))
  (setf **cell-size-left-shift** (ceiling (/ **cell-size** 3))
        **cell-size-up-shift** (ceiling (/ (* 2 **cell-size**) 3)))
  (setf **top-poly**
        (create-top window
                    cell-size 
                    **cell-size-left-shift**
                    **cell-size-up-shift**)
        **left-poly**
        (create-left window
                     cell-size 
                     **cell-size-left-shift**
                     **cell-size-up-shift**)
        **front-poly**
        (create-front window
                      cell-size)
        **back-frame-poly**
        (create-back-frame-poly window
                                cell-size
                                **cell-size-left-shift**
                                **cell-size-up-shift**))
  (pre-compute-offset-poly-array **tetris-board**))

(defun create-top (window &optional (size 15)(left-shift 5)(up-shift 10))
  (list 0 0
        size 0
        (- size left-shift) (- up-shift)
        (- left-shift) (- up-shift)
        0 0))

(defun create-left (window &optional (size 15)(left-shift 5)(up-shift 10))
  (list 0 0
        (- left-shift) (- up-shift)
        (- left-shift) (- size up-shift)
        0 size
        0 0))


(defun create-front (window &optional (size 15))
  (list 0 0
        size 0
        size size
        0 size
        0 0))

(defun create-back-frame-poly (window  &optional (size 15)(left-shift 5)(up-shift 10))
  (let ((back-x (- size left-shift))
        (back-y (- size up-shift)))
    (list (- back-x size) back-y
          back-x back-y
          back-x (- back-y size)
          back-x back-y
          size size)))

(defun pre-compute-offset-poly-array (tetris-board)
  (setf **pre-computed-poly-offset-array**
        (make-array (array-dimensions tetris-board)))
  (loop for row from 0 below (array-dimension tetris-board 0)
        do
        (loop for col from 0 below (array-dimension tetris-board 1)
              do
              (loop for dep from 0 below (array-dimension tetris-board 2)
                    do
                    (record-cell-polys row col dep)))))

(defun record-cell-polys (row col dep
                              &optional
                              (row-offset 0)
                              (col-offset 0)
                              (cell-size  **cell-size**))
  (let* ((final-row (+ row row-offset))
	 (final-col (+ col col-offset))
         (left (+ (* cell-size final-col) (* (- **last-dep** dep) **cell-size-left-shift**)))
         (top (+ (* cell-size final-row) (* (- **last-dep** dep) **cell-size-up-shift**))))
    (setf (aref **pre-computed-poly-offset-array** row col dep)
          (list (offset-poly **top-poly** left top)
                (offset-poly **left-poly** left top)
                (offset-poly **front-poly** left top)
                (offset-poly **back-frame-poly** left top)))))

(defun draw-cube-at-x-y (x y &optional
                           (front-color *blue-color*)
                           (top-color *light-blue-color*)
                           (left-color *light-blue-color*)
                           (cell-size **cell-size**)
                           (window **tetris-window**)
                           (translucent? nil))
;  (fill-rect window x y cell-size cell-size :color front-color)
;  (draw-rect window x y cell-size cell-size :color **frame-color**)
  (draw-poly-at-x-y x y **front-poly** :window window :color front-color)
  (draw-poly-at-x-y x y **top-poly** :window window :color top-color)
  (draw-poly-at-x-y x y **left-poly** :window window :color left-color)
  (when translucent?
    (draw-poly window
               (offset-poly **back-frame-poly** x y)
               :color **frame-color**
               :filled? nil)))

(defun draw-translucent-cube-at-x-y (x y &optional
                                       (front-color *blue-color*)
                                       (top-color *light-blue-color*)
                                       (left-color *light-blue-color*)
                                       (cell-size **cell-size**)
                                       (window **tetris-window**))
  (draw-cube-at-x-y x y front-color top-color left-color cell-size window t))


;; New representation of poly is a point list, eg (0 0 100 20 50 100 0 0)
;;  Better idea would be to pre-compute all the offset poly's, so never have
;;    to compute offsets on the fly. Store poly's for each board location
(defun draw-poly-at-x-y (x y poly &key
                           (window **tetris-window**) 
                           (color **foreground-color**))
  (let ((shifted-poly (offset-poly poly x y)))
    (draw-poly window shifted-poly  :filled? t :color color)
    (draw-poly window shifted-poly :filled? nil :color **frame-color**)))

(defun offset-poly (poly x y)
  (loop with new-poly = (append poly nil)
        for points = new-poly then (cddr points)
        while points
        do
        (incf (first points) x)
        (incf (second points) y)
        finally
        (return new-poly)))


  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GWorld cube graphics
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **cube-mask-gw** nil)      	; all-white cube on black for mask
(defparameter **red-cube** nil)         	; background cube
(defparameter **blue-cube** nil)        	; normal cube
(defparameter **light-blue-cube** nil)          ; for flash
(defparameter **empty-target-cube** nil)        ; light green
(defparameter **filled-target-cube** nil)       ; dark green
(defparameter **solved-target-cube** nil)       ; gold



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tetris Dialog Control Box
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun abort-existing-tetris ()
  (set-game-status 'game-aborted)
  (when **tetris-process**
    (mp:process-kill **tetris-process**)))

(defun start-tetris ()
;  (load-demo-solutions)
;  (load "ccl:tetris;grid-editor-3d.lisp")
;  (close-title-window)
;  (move-listener-window)
  (create-tetris-dialog))

(defun create-tetris-dialog () ; always make a new one for now (until know how to check if one exists)
  (tetris-target-3d-control-panel)
  (setf **piece-count-text-box** (view-named 'piece-count-box 'tetris-window)
        **lines-cleared-text-box** (view-named 'lines-cleared-box 'tetris-window)
        **targets-solved-text-box** (view-named 'targets-solved-box 'tetris-window))
  ;; (domino-menu-item-action)
  (L-piece-menu-item-action) ; corresponds to selection 4 of option-pane item-list
  ;; (T-piece-menu-item-action)
  ;; (small-L-menu-item-action)
  )

;; For use with LispWorks
(defun tetris-target-3d-control-panel ()
  (let* ((header-size 20)
         (width 400)
         (height 600)
         (pinboardlayout
          (make-instance
           'capi:pinboard-layout
           :description
           (list (setf title1
                       (create-text-item "Game Control" 120 5 header-size))
                 (create-button "Start Game" 
                                '(start-game-button-action)
                                10 40)
                 (create-button "Help" '(help-button-action) 10 70)
                 (create-option-pane "Line Clearing"
                                     '("single" "double" "triple" "quadruple")
                                     140 40
                                     'line-clearing-option-pane-callback)
                (create-option-pane "Piece Type(s)"
                                     '("Domino"
                                       "Domino 3"
                                       "Small L"
                                       "T shaped piece"
                                       "L shaped piece"
                                       "Z shaped piece"
                                       "P pentomino"
                                       "T-L Piece Sequence"
                                       "T-L-Square Piece Sequence"
                                       "T-L-Square-F Piece Sequence"
                                       "All 2d pieces"
                                       "All 3d pieces"
                                       "Standard Tetris Pieces"
                                       "Prompt for piece sequence")
                                     140 70
                                     'piece-type-option-pane-callback
                                     4)    ; 4 = "L shaped piece"
                 (create-check-box "Beginner's Training"
                                   'beginners-training-checkbox-action
                                   20 110)
                 (create-check-box "Random Next Piece"
                                   'random-next-piece-checkbox-action
                                   20 130)
                 (create-check-box "Enable piece reflection"
                                   'enable-piece-reflection-checkbox-action
                                   200 110)
                 (create-text-item "Board Parameters" 100 165 header-size)
                 (create-text-box  " Rows" 'BOARD-ROWS-BOX 20 190 "20")
                 (create-text-box  " Cols " 'BOARD-COLS-BOX 22 220 "5")
                 (create-text-box  "Depth" 'BOARD-DEPS-BOX 20 250 "1")
                 (create-text-box  "Random Fill Rows" 'BOARD-FILL-BOX 200 190 "0")
                 (create-button "Edit Start Board"
                                '(EDIT-START-BOARD-BUTTON-ACTION)
                                200 220)
                 (create-check-box "Use Edited Start Board"
                                   'use-start-board-checkbox-action
                                   220 250)
                 (create-text-box "Max Edit Height"
                                  'MAX-EDIT-HEIGHT-BOX
                                  200 270 "10")
                 (create-text-item "Target Parameters" 100 305 header-size)
                 (create-text-box  "Target Count" 
                                   'TARGET-COUNT-BOX 
                                   20 340 "0")
                 (create-text-box "Target Rows" 'TARGET-ROWS-BOX 25 370 "0")
                 (create-button "Edit Targets"
                                '(EDIT-TARGET-BOARD-BUTTON-ACTION)
                                220 340)
                 (create-check-box "Use Edited Target Board"
                                   'use-target-board-checkbox-action
                                   230 370)
                 (create-text-item "Game Stats Display" 100 400 header-size)
                 (create-text-box "Piece Count" 'PIECE-COUNT-BOX 37 430 "0")
                 (create-text-box "Lines Cleared" 'LINES-CLEARED-BOX 27 460 "0")
                 (create-text-box "Targets Solved" 'TARGETS-SOLVED-BOX 20 490 "0")
                 (create-button "Reset Stats" '(reset-stats-button-action)
                                200 450)))))
    (capi:contain pinboardlayout
                  :best-width width
                  :best-height height
                  :best-x 600
                  :best-y 50
                  :title "Target Tiling 3D")
    (sleep 1)
    ;(draw-grid-lines pinboardlayout width height 100)
    pinboardlayout))

(defun start-game-button-action ()
  (abort-existing-tetris)
  (unless **tetris-window**
    (setf **tetris-window**
          (create-tetris-window)))
  (capi:activate-pane **tetris-window**)
  (setf **tetris-process**
        (mp:process-run-function 'tetris-process nil
                                 #'play-tetris-button-action)))

(defun play-tetris-button-action ()
  (setf **original-tetris** nil)
  (reset-key-input-queue)
  (reset-stats-button-action)
  (replay-tetris))

(defun replay-tetris ()
  (reset-key-input-queue)
  (if **original-tetris**
      (replay-original-tetris)
    (if **pre-defined-levels-selected-by-radio-button**
        (play-tetris-pre-defined)
      (play-tetris-manual))))

(defun replay-original-tetris ()
  ;(toplevel) ;does this work?  figure out right thing to do?
  )

(defun play-tetris-pre-defined ()
  (play-tetris 20
               **pre-defined-level-board-width**
               1
               (if (listp **piece-type-from-menu**)
                   **piece-type-from-menu**
                 (list **piece-type-from-menu**))
               0))

(defun play-tetris-manual ()
  (reset-key-input-queue)
  (let* ((tetris-window 'ignore)
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (board-cols (get-dialog-box-value 'board-cols-box tetris-window))
         (board-deps (get-dialog-box-value 'board-deps-box tetris-window))
         (board-fill (get-dialog-box-value 'board-fill-box tetris-window))
         (target-count (get-dialog-box-value 'target-count-box tetris-window))
         (target-rows (get-dialog-box-value 'target-rows-box tetris-window)))
    (play-tetris board-rows
                 board-cols
                 board-deps
                 (if (listp **piece-type-from-menu**)
                     **piece-type-from-menu**
                   (list **piece-type-from-menu**))
                 0
                 board-fill
                 target-rows
                 target-count)))

;; shouldn't need this any more
(defun play-tetris-manual-edited ()
  (let* ((tetris-window (find-window "Target Tiling 3D Game"))
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (board-cols (get-dialog-box-value 'board-cols-box tetris-window))
         (board-deps (get-dialog-box-value 'board-deps-box tetris-window))
         (board-fill (get-dialog-box-value 'board-fill-box tetris-window)))
    (setf **edited-targets** t)
    (cond ((null **grid-click-view**)
           (message-dialog "There is no edited target grid")
           )
          ((not (edited-board-parameters-ok? board-rows board-cols board-deps))
           (message-dialog "The board parameters do not match the edited target board")
           )
          (t
           (play-tetris board-rows
                        board-cols
                        board-deps
                        (if (listp **piece-type-from-menu**)
                            **piece-type-from-menu**
                          (list **piece-type-from-menu**))
                        0
                        board-fill)))))

(defun edited-board-parameters-ok? (grid-click-view)
  (let* ((tetris-window (find-window "Target Tiling 3D Game"))
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (board-cols (get-dialog-box-value 'board-cols-box tetris-window))
         (board-deps (get-dialog-box-value 'board-deps-box tetris-window))
         (edit-grid-rows (3d-rows grid-click-view))
         (edit-grid-cols (3d-cols grid-click-view))
         (edit-grid-deps (3d-deps grid-click-view)))
    (and (>= board-rows edit-grid-rows)
         (eql board-cols edit-grid-cols)
         (eql board-deps edit-grid-deps))))

(defun get-dialog-box-value (name view)
  (read-from-string (dialog-item-text (view-named name view))))

(defun update-text-box (box value)
  (set-dialog-item-text box
                        (format nil "~a" value)))

(defun line-clearing-option-pane-callback (selection interface)
  (cond ((string= selection "single")
         (setf **consecutive-full-row-requirement** 1))
        ((string= selection "double")
         (setf **consecutive-full-row-requirement** 2))
        ((string= selection "triple")
         (setf **consecutive-full-row-requirement** 3))
        ((string= selection "quadruple")
         (setf **consecutive-full-row-requirement** 4))))

(defun piece-type-option-pane-callback (selection interface)
  (cond ((string= selection "Domino") 
         (DOMINO-MENU-ITEM-ACTION))
        ((string= selection "Domino 3")
         (DOMINO-3-MENU-ITEM-ACTION))
        ((string= selection "Small L")
         (SMALL-L-MENU-ITEM-ACTION))
        ((string= selection "T shaped piece")
         (T-PIECE-MENU-ITEM-ACTION))
        ((string= selection "L shaped piece")
         (L-PIECE-MENU-ITEM-ACTION))
        ((string= selection "Z shaped piece")
         (Z-SHAPED-PIECE-MENU-ITEM-ACTION))
        ((string= selection "P pentomino")
         (P-PENTOMINO-MENU-ITEM-ACTION))
        ((string= selection "T-L Piece Sequence")
         (T-L-MENU-ITEM-ACTION))
        ((string= selection "T-L-Square Piece Sequence")
         (T-L-SQUARE-MENU-ITEM-ACTION))
        ((string= selection "T-L-Square-F Piece Sequence")
         (T-L-SQUARE-F-MENU-ITEM-ACTION))
        ((string= selection "All 2d pieces")
         (ALL-2D-PIECES-MENU-ITEM-ACTION))
        ((string= selection "All 3d pieces")
         (ALL-3D-PIECES-MENU-ITEM-ACTION))
        ((string= selection "Standard Tetris Pieces")
         (STANDARD-TETRIS-MENU-ITEM-ACTION))
        ((string= selection "Prompt for piece sequence")
         (PROMPT-FOR-PIECE-SEQUENCE-MENU-ITEM-ACTION))))

(defun p-pentomino-menu-item-action ()
  (setf **piece-type-from-menu** 20))

(defun Z-shaped-piece-menu-item-action ()
  (setf **piece-type-from-menu** 9))

(defun L-piece-menu-item-action ()
  (setf **piece-type-from-menu** 7))

(defun T-piece-menu-item-action ()
  (setf **piece-type-from-menu** 6))

(defun small-L-menu-item-action ()
  (setf **piece-type-from-menu** 3))

(defun domino-menu-item-action ()
  (setf **piece-type-from-menu** 1))

(defun domino-3-menu-item-action ()
  (setf **piece-type-from-menu** 2))

(defun t-l-menu-item-action ()
  (setf **piece-type-from-menu** (list 6 7)))

(defun t-l-square-menu-item-action ()
  (setf **piece-type-from-menu** (list 6 7 8)))

(defun t-l-square-f-menu-item-action ()
  (setf **piece-type-from-menu** (list 6 7 8 11)))

;; new
(defun standard-tetris-menu-item-action ()
  (setf **piece-type-from-menu** (list 4 5 6 7 8 9 10)))

(defun all-2d-pieces-menu-item-action ()
  (setf **piece-type-from-menu**
        (remove 11 (remove 12 (remove 13 (all-piece-types))))))

(defun all-3d-pieces-menu-item-action ()
  (setf **piece-type-from-menu** (all-piece-types)))

(defun prompt-for-piece-sequence-menu-item-action ()
  (let* ((piece-string (get-string-from-user "Enter piece types (integers) separated by spaces"))
         (piece-list (read-from-string (format nil "(~a)" piece-string))))
    (when (stringp piece-string)
      (setf **piece-type-from-menu** piece-list))))

(defun all-piece-types ()
  (loop for i from 0 to 31 collect i))

(defun reset-stats-button-action ()
  (setf **piece-count** 0)
  (setf **total-lines-cleared** 0)
  (setf **targets-solved-count** 0)
  (display-piece-count)
  (display-cleared-lines)
  (update-targets-solved-box))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Help
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter **help-text-string**
  "The OBJECTIVE is to EXACTLY MATCH the targets (hollow green)
  with the pattern of blue cells.
      (If there are no targets visible, then the object
        is to clear the screen (a \"wipeout\").

        These are the Target Tiling 3D key commands:

        J j or 4         Move piece left
        L l or 6         Move piece right
        K k or 5         Move piece back
        I i or 8         Move piece forward
        U u or 7         Reflect piece left-right (when reflection is enabled)
        A or a           Rotate piece so that it falls forward
        Z or z           Rotate piece so that it falls back
        S or s           Rotate piece so that it falls to the right
        X or x           Rotate piece so that it falls to the left
        D or d           Rotate piece so that it spins to the right (around vertical axis)
        C or c           Rotate piece so that it spins to the left (around vertical axis)
        space or 0       Drop piece
        B or b           Drop piece But 1 (can still move horizontally after fall)
        *                Zoom - make piece fall faster
        T t or -         Take back last move
        G g or +         Go forward move (undo takeback)
        F or f           Faster speed
        W or w           Slower speed (mnemonic is \"Whoa\")
        N or n           Toggle show next piece
        R or r           Redisplay board
        P p or =         Pause game (toggle)
        Q                Quit game (NOTE: must be shifted to avoid accidental quits)

        Click on the \"Start Game\" button to begin")

(defun help-button-action ()
  (let ((help-win (make-window 800 700 "Target Tiling 3D Info"
                               400 10)))
    (set-view-font help-win '("Monaco" 14 :bold))
    (display-multi-line-string help-win **help-text-string**)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Target Editor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; reuse grid-click-view??

(defun edit-target-board-button-action ()
  (when **target-grid-click-view**
    (window-close **target-grid-click-view**))
  (setf **target-grid-click-view**
        (create-3d-grid-click-view 10 3 3))
  (set-window-title **target-grid-click-view**
                    "Target Editor")
  (let* ((board-rows (get-dialog-box-value 'board-rows-box 'ignore))
         (board-cols (get-dialog-box-value 'board-cols-box 'ignore))
         (board-deps (get-dialog-box-value 'board-deps-box 'ignore))
         (max-edit-height (get-dialog-box-value 'max-edit-height-box 'ignore)))
    (resize-grid **target-grid-click-view** (min max-edit-height board-rows) board-cols board-deps))
  (window-select **target-grid-click-view**))

(defun edit-start-board-button-action ()
  (when **start-grid-click-view**
    (window-close **start-grid-click-view**))
  (setf **start-grid-click-view**
        (create-3d-grid-click-view 10 3 3))
  (set-window-title **start-grid-click-view**
                    "Start Board Editor")
  (let* ((tetris-window (find-window "Target Tiling 3D Game"))
         (board-rows (get-dialog-box-value 'board-rows-box tetris-window))
         (board-cols (get-dialog-box-value 'board-cols-box tetris-window))
         (board-deps (get-dialog-box-value 'board-deps-box tetris-window))
         (max-edit-height (get-dialog-box-value 'max-edit-height-box tetris-window)))
    (resize-grid **start-grid-click-view** (min max-edit-height board-rows) board-cols board-deps))
  (window-select **start-grid-click-view**))

;(defun play-game-using-edited-targets-button-action ()
;  (reset-stats-button-action)
;  (play-tetris-manual-edited))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Solvability Analysis
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun solvable? (width height piece-sequence start-grid target-grid)
  (let ((start-count (count-grid start-grid width height))
        (target-count (count-grid target-grid width height))
        (piece-count-list (loop for piece in piece-sequence
                                collect (piece-size piece))))
    (cond ((not (simple-counting-is-ok? width piece-count-list start-count target-count))
           (warn "This combination of piece-sequence, width, start, and target is impossible")
           nil)
          (t
           t))))

(defun piece-size (piece-type)
  (aref **piece-sizes** piece-type))

(defun count-grid (grid width height)
  (loop with array-cols = (array-dimension grid 0)
        for row from (- array-cols 2) downto (- array-cols (1- height) 2)
        sum
        (count-row row grid width)))

(defun count-row (row grid width)
  (loop for col from 1 to width
        count (aref grid row col)))

(defun simple-counting-is-ok? (width piece-count-list start-count target-count)
  (loop with sequence-piece-count = (apply #'+ piece-count-list)
        for new-start-count = start-count then (+ start-count piece-count)
        for piece-count in piece-count-list
        thereis
        (single-piece-counting-is-ok? width sequence-piece-count new-start-count target-count)))

(defun single-piece-counting-is-ok? (width piece-count start-count target-count)
  ;;  gcd(piece-count,width) must divide (- target-count start-count)
  (zerop (mod (- target-count start-count) (gcd piece-count width))))


;;; Domino Analyzer

(defun domino-solvable? (width height start-grid target-grid)
  ;;  If platform is constructable, then any pattern is possible
  ;;  If not, then every piece must be supported via cantilever
  ;;     (ie has adjacent cell that is directly supported)
  ;;       [NOTE: a directly supported cell can only support ONE cell
  ;;		    via cantilever]
  ;;   NOTE also: that if there is an excess (of 1),
  ;;        then one of the cells in the pattern must be directly supported (alone)
  ;;          (and CANNOT CANTILEVER).
  (loop with gcd = (gcd 2 width)
        with start-count = (count-grid start-grid width height)
        with support-row = (make-array width :initial-element t)
        with current-row = (make-array width :initial-element t)
        with support-marks = (make-array width)
        with bottom-row-num = (- (array-dimension target-grid 0) 2)
        for last-excess = 0 then excess
        for excess = (mod start-count gcd) then (mod (+ excess row-count) gcd)
        for row from bottom-row-num above (- bottom-row-num height)
        for row-count = (count-row row target-grid width)
        do
        (replace support-row current-row)
        (loop for grid-col from 1 to width
              for col from 0
              do
              (setf (aref current-row col)
                    (aref target-grid row grid-col)))
        always
        (or (can-build-platform? support-row support-marks excess width)
            (can-support-all-targets? current-row support-row support-marks excess width))))

(defun can-build-platform? (support-row support-marks excess width)
  (fill support-marks nil)
  (loop for col from 0 below width
        do
        (mark-support col support-row support-marks))
  (and (<= excess (count-unmarked-supports width support-row support-marks))
       (loop for col from 0 below width
             always
             (or (aref support-marks col)
                 (aref support-row col)))))

(defun mark-support (col support-row support-marks)
  (cond ((direct-support? col))
        ((left-support? col support-row support-marks)
         (set-this-mark (1- col) support-marks)
         (set-this-mark col support-marks))
        ((right-support? col support-row support-marks)
         (set-this-mark (1+ col) support-marks)
         (set-this-mark col support-marks))))

(defun set-this-mark (col support-marks)
  (setf (aref support-marks col) t))

(defun direct-support? (col support-row)
  (aref support-row col))

(defun left-support? (col support-row support-marks)
  (and (array-in-bounds-p support-row (1- col))
       (aref support-row (1- col))
       (not (aref support-marks (1- col)))))

(defun right-support? (col support-row support-marks)
  (and (array-in-bounds-p support-row (1- col))
       (aref support-row (1+ col))
       (not (aref support-marks (1+ col)))))

(defun count-unmarked-supports (width support-row support-marks)
  (loop for col from 0 below width
        count
        (and (aref support-row col)
             (not (aref support-marks col)))))



(defun can-support-all-targets? (current-row support-row support-marks excess width)
  (fill support-marks nil)
  (loop for col from 0 below width
        do
        (mark-cantilever-support col current-row support-row support-marks))
  (and (<= excess (count-unmarked-supports width support-row support-marks))
       (loop for col from 0 below width
             always
             (or (aref support-marks col)
                 (aref support-row col)))))


(defun mark-cantilever-support (col current-row support-row support-marks excess width)
  (cond ((not (aref current-row col)))          ; do nothing if not a target
        ((direct-support? col))        		; do nothing if directly supported
        ((left-cantilever? col current-row support-row support-marks)
         (cond ((right-cantilever? col current-row support-row support-marks)
                ; left or right
                (setf (aref current-row (1- col)) 'a)       ; alternate cantilever
                (setf (aref current-row (1+ col)) 'a)       ; alternate cantilever
                )
               (t
                (if (aref current-row 'a)       ; alternate cantilever
                  (propagate-left-forced-cantilever (1- col))
                  (setf (aref current-row (1- col)) 'c))))       ; must cantilever this side
         (setf (aref current-row col) 'c))       ; must cantilever
        ((right-cantilever? col current-row support-row support-marks)
         (setf (aref current-row col) 'c))       ; must cantilever
         (setf (aref current-row (1+ col)) 'c)))       ; must cantilever

(defun propagate-left-forced-cantilever (start-col current-row)
  (loop for col from start-col downto 0 by 2
        while (eql (aref current-row col) 'a)
        do
        (setf (aref current-row col) 'c)))

(defun left-cantilever? (col current-row support-row support-marks)
  (and (left-support? col support-row support-marks)
       (not (member (aref current-row (1- col))
                    '(nil c f)))))    ; c = cantilever, a = alternate cantilever, f = forced from below

(defun right-cantilever? (col current-row support-row support-marks)
  (and (right-support? col support-row support-marks)
       (not (member (aref current-row (1+ col))
                    '(nil c f)))))    ; c = cantilever, a = alternate cantilever, f = forced from below




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Saving Solutions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun collect-solution-data ()
  (list :last-row **last-row**
        :last-col **last-col**
        :piece-type **piece-type**
        :piece-count 
        :start-cells
        :target-cells
        ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; todo
;    auto increase levels
;    hide top of board??
;    ELIMINATE unnecessary consing (use virtual sets = fixed sets with offsets)

;    Fix input to come from display?
;       OR else Fix Listener so it is selected (and sized to be out of the way ...

;    Make into stand-alone application?

;    Make pieces fall faster (eliminate type-in echo in Listener)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Start Up Game
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


#|
(when (probe-file "ccl:tetris;tetris-target-title-dialog.lisp")
;  (move-listener-window)
  (load "ccl:tetris;tetris-target-title-dialog.lisp")
  (loop for title-window = (find-window "Tetris Title")
        until title-window
        do
        (sleep 1)
        finally
        (window-select title-window)))
|#

(start-tetris)

;;  HOW TO USE (for now):
;;    1. Compile and load or evaluate this file
;;    2. Select setup parameters from control panel
;;    3. Click on "Start Game" button
;;    4. Click on "Help" button to see key commands


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  GRID EDITOR 3D
;;;
;;;  (from "grid-editor-3d.lisp" modified to work with LispWorks
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Modified to run with LispWorks
;;  Need to load " mygraphics.lisp"

(defclass 3d-grid-click-view (capi::output-pane)
  ((cell-size :initform 30 :accessor cell-size)
   (3d-rows :initform 7 :accessor 3d-rows)
   (3d-cols :initform 7 :accessor 3d-cols)
   (3d-deps :initform 3 :accessor 3d-deps)
   (3d-grid :initform (make-array (list 7 7 3) :initial-element 0)
            :accessor 3d-grid)
   (rows :initform 7 :accessor rows)
   (cols :initform 7 :accessor cols)
   (grid :initform (make-array (list 21 3) :initial-element 0)
         :accessor grid)
   (flip-rows? :initform nil)
   (flip-cols? :initform nil)
   (flip-deps? :initform t)))

(defmethod view-draw-contents ((gcv 3d-grid-click-view))
  (with-slots (cell-size rows cols)
              gcv
    (clear-window gcv)
    (loop for row from 0 below rows
          do
          (loop for col from 0 below cols
                do
                (draw-grid-cell gcv row col)))
    (draw-grid-lines gcv)
    (draw-3d-borders gcv)))

(defmethod resize-draw-contents ((gcv 3d-grid-click-view) x y w h)
  (capi:apply-in-pane-process
   gcv
   'view-draw-contents gcv))

(defmethod draw-grid-cell ((gvc 3d-grid-click-view) row col)
  (with-slots (cell-size grid)
              gvc
    (if (zerop (aref grid row col))
      (set-fore-color gvc :white)
      (set-fore-color gvc :blue))
    (fill-rect gvc
               (* col cell-size)
               (* row cell-size)
               cell-size
               cell-size)))

(defmethod view-click-event-handler ((gcv 3d-grid-click-view) x y type)
  (with-slots (grid cell-size)
              gcv
    (let ((row (floor y cell-size))
          (col (floor x cell-size)))
      (when (array-in-bounds-p grid row col)
        (setf (aref grid row col)
              (- 1 (aref grid row col)))
        (copy-to-3d-grid gcv row col)
        ;(draw-grid-cell gcv row col)
        (view-draw-contents gcv))
      )))

(defmethod copy-to-3d-grid ((gcv 3d-grid-click-view) row col)
  (with-slots (3d-rows 3d-cols 3d-deps 3d-grid grid flip-rows? flip-cols? flip-deps?)
              gcv
    (let ((3d-row (floor row 3d-deps))
          (3d-col col)
          (3d-dep (mod row 3d-deps)))
      (when flip-rows?
        (setf 3d-row (- 3d-rows 1 3d-row)))
      (when flip-cols?
        (setf 3d-col (- 3d-cols 1 3d-col)))
      (when flip-deps?
        (setf 3d-dep (- 3d-deps 1 3d-dep)))
      (setf (aref 3d-grid 3d-row 3d-col 3d-dep)
            (aref grid row col)))))

(defmethod draw-grid-lines ((gcv 3d-grid-click-view))
  (with-slots (rows cols cell-size)
              gcv
    (set-fore-color gcv :gray)
    (loop with height = (* cell-size rows)
	  for col from 0 to cols do
          (draw-grid-line gcv (* cell-size col) 0 (* cell-size col) height))
    (loop with width = (* cell-size cols)
	  for row from 0 to rows do
          (draw-grid-line gcv 0 (* cell-size row) width (* cell-size row)))))

(defmethod draw-grid-line ((gcv 3d-grid-click-view) from-x from-y to-x to-y)
  (draw-line gcv from-x from-y to-x to-y))

(defmethod draw-3d-borders ((gcv 3d-grid-click-view))
  (with-slots (3d-deps rows cols cell-size)
              gcv
    (set-fore-color gcv :blue)
    (loop with height = (* cell-size rows)
	  for col from 0 to cols by cols do
          (draw-grid-line gcv (* cell-size col) 0 (* cell-size col) height))
    (loop with width = (* cell-size cols)
	  for row from 0 to rows by 3d-deps do
          (draw-grid-line gcv 0 (* cell-size row) width (* cell-size row)))))

(defmethod resize-grid ((gcv 3d-grid-click-view) new-3d-rows new-3d-cols new-3d-deps)
  (with-slots (3d-rows 3d-cols 3d-deps 3d-grid rows cols grid)
              gcv
    (setf 3d-rows new-3d-rows
          3d-cols new-3d-cols
          3d-deps new-3d-deps)
    (setf 3d-grid (make-array (list 3d-rows 3d-cols 3d-deps) :initial-element 0))
    (setf rows (* 3d-rows 3d-deps)
          cols 3d-cols)
    (setf grid (make-array (list rows cols) :initial-element 0)))
  (capi:apply-in-pane-process
   gcv
   'view-draw-contents gcv))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Create a 3D-Grid-click-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun create-3d-grid-click-view (3d-rows 3d-cols 3d-deps &optional (grid-cell-size 15))
  (let ((gcv (make-instance '3d-grid-click-view
                            :display-callback 'resize-draw-contents
                            :resize-callback 'resize-draw-contents
                            :input-model
                             '(
                                ((:button-1 :press)
                                 view-click-event-handler
                                 "Button-1 press")))))
    (resize-grid gcv 3d-rows 3d-cols 3d-deps)
    (with-slots (cell-size)
                gcv
      (setf cell-size grid-cell-size))
;    (set-view-size gcv 250 350)
    (capi:contain gcv :title "Grid Editor 3D")
    (capi:apply-in-pane-process gcv
                                'view-draw-contents
                                gcv)
    gcv))