#|
CSU290 Homework 2 - Fall 2008

Student name 1:  TODO: PUT ONE NAME HERE
Student name 2:  TODO: PUT OTHER NAME HERE

This homework should be completed in Programming mode.

You should turn in a .lisp file (this one!) for which all the forms are
accepted by ACL2; thus, please delete or comment out any parts you haven't
completed by turn-in time.
|#

; Assignment:
; Complete the definition and write tests for the following functions.
;
; Each one adds some functionality to the game you get if you move the
; line all the way to the bottom.  (It is a variant of "Connect Four",
; trademark Milton Bradley.)


;=> ADD-TO-FRONT will allow you to drop a disc into a new column on the left

; ADD-TO-FRONT: all true-list -> true-list
; Returns a list with e (first parameter) as first element and list l
; (second parameter) as rest of the returned list.
; (This should be *very* easy.)
; Example: (add-to-front 1 '(2 3)) = '(1 2 3)
; (please write at least 5 tests)
(defun add-to-front (e l)
  (declare (ignore e)) ; TODO: remove this line and fill in definition
  l)

;=> ADD-TO-END will allow you to drop a disc into a new column on the right

; ADD-TO-END: all true-list -> true-list
; Returns a list with the elements of list l (second parameter) and e
; (first parameter) as the last element.
; (Do not use APPEND.  Requires recursion.)
; Example: (add-to-end 3 '(1 2)) = '(1 2 3)
; (please write at least 5 tests)
(defun add-to-end (e l)
  (declare (ignore e)) ; TODO: remove this line and fill in definition
  l)


;=> ADD-TO-END-OF-NTH will allow you to drop discs into columns that already
;=> have one (or more).

; For the next function consider a data definition for lists of lists:
; datatype true-list-list: nil | Cons true-list true-list-list

; ADD-TO-END-OF-NTH: all true-list-list nat -> true-list-list
; Returns a list of lists like ll (second parameter) except that e (first
; parameter) has been added to the end of the nth (third parameter n)
; (zero-based indexing) element/list of ll.
; (Use ADD-TO-END.  Do not use UPDATE-NTH or APPEND.)
; Example: (add-to-end-of-nth 4 '((1) (2 3) (5)) 1) = '((1) (2 3 4) (5))
; (please write at least 5 tests)
(defun add-to-end-of-nth (e ll n)
  (declare (ignore e n)) ; TODO: remove this line and fill in definition
  ll)


;=> FIND-4-SEQUENCE will be used in FIND-4-SEQUENCE-VERTICAL, which will allow
;=> the game to end when 4 in a row appear vertically.

; For the next function consider a data definition for an optional element:
; datatype maybe: nil | Cons all nil
; nil means "nothing found".  (cons x nil) means "x was found".

; FIND-4-SEQUENCE: true-list -> maybe
; Searches the list l (only parameter) for four occurrences in a row of the
; same value.  If found, returns (cons <value> nil).  Otherwise, returns nil.
; (You may want to write helper function(s) above this one. (not required))
; Example: (find-4-sequence '(1 1 1 2 3 3 3 3 4)) = '(3)
; (please write at least 5 tests)
(defun find-4-sequence (l)
  (declare (ignore l)) ; TODO: remove this line and fill in definition
  nil)

; FIND-4-SEQUENCE-VERTICAL: true-list-list -> maybe
; Searches each list of the list of lists ll (only parameter) for four
; consecutive occurrences of the same value.  If found, returns
; (cons <value> nil).  Otherwise, returns nil.
; (You should use FIND-4-SEQUENCE.)
; Example: (find-4-sequence-vertical '((1) (1 2 3 3 3 3 4) ())) = '(3)
; (please write at least 5 tests)
(defun find-4-sequence-vertical (ll)
  (declare (ignore ll)) ; TODO: remove this line and fill in definition
  nil)


;############################################################################;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  The rest of this homework is completely optional.  You are welcome to ;;;
;;; take on the challenge, but nothing after here is required.             ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;############################################################################;

(defun find-4-sequence-horizontal (ll)
  (declare (ignore ll)) ; remove this line if you give a definition
  nil)

(defun find-4-sequence-diagonal1 (ll)
  (declare (ignore ll)) ; remove this line if you give a definition
  nil)

(defun find-4-sequence-diagonal2 (ll)
  (declare (ignore ll)) ; remove this line if you give a definition
  nil)


;############################################################################;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DO NOT MODIFY BELOW THIS POINT (unless you know what you are doing)    ;;;
;;; If you preserve the names and parameter lists of the functions above,  ;;;
;;; you should not need to modify anything below here.  You should be able ;;;
;;; to move the line to the bottom to get the GUI.                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;############################################################################;

(progn
(include-book "graphics" :dir :acl2s :ttags :all)

(defconst *initial-config*
  (cons nil ; next turn is whose
        nil ; no columns to start
        ))

(defun present-column (colidx idx configcol width height pres)
  (if (endp configcol)
    pres
    (present-column colidx (+ 1 idx)
                    (cdr configcol)
                    width height
                    (fill-oval (/ colidx width) (- 1 (/ (+ idx 1) height)) (/ width) (/ height)
                               (if (car configcol) 'blue 'red)
                               pres))))

(defun present-columns (idx config-cols width height pres)
  (if (endp config-cols)
    pres
    (present-columns (+ 1 idx)
                     (cdr config-cols)
                     width height
                     (present-column idx 0 (car config-cols) width height pres))))

(defun max-len (ll)
  (if (endp ll)
    0
    (max (len (car ll))
         (max-len (cdr ll)))))

(defun draw-vertical-lines0 (i n pres)
  (if (zp i)
    pres
    (draw-vertical-lines0
     (- i 1) n
     (draw-line (/ i n) 0 (/ i n) 1 'black pres))))                     
    
(defun draw-vertical-lines (columns pres)
  (draw-vertical-lines0 (- columns 1) columns pres))

(defun presenter (config pres)
  (let* ((config-cols (cdr config))
         (used-width (len config-cols))
         (used-height (max-len config-cols))
         (pres-width (+ 2 used-width))
         (pres-height (max pres-width (+ 1 used-height)))
         (pres (fill-rect 0 0 1 1
                          (if (consp (car config))
                            'gray
                            'white)
                          pres))
         (pres (draw-vertical-lines pres-width pres))
         (pres (set-status-bar (if (consp (car config))
                                 (if (caar config)
                                   "Blue wins!"
                                   "Red wins!")
                                 (if (car config)
                                   "Blue's turn"
                                   "Red's turn"))
                               pres))
         (pres (present-columns 1 config-cols pres-width pres-height pres)))
    pres))

(defun find-4-sequence-any (ll)
  (let ((v (find-4-sequence-vertical ll)))
    (if (consp v)
      v
      (let ((h (find-4-sequence-horizontal ll)))
        (if (consp h)
          h
          (let ((d1 (find-4-sequence-diagonal1 ll)))
            (if (consp d1)
              d1
              (find-4-sequence-diagonal2 ll))))))))

(defun dropper (button x y config)
  (declare (ignore button y))
  (let* ((whose-turn (car config)))
    (if (consp whose-turn)
      *initial-config*
      (let* ((config-cols (cdr config))
             (used-width (len config-cols))
             (pres-width (+ 2 used-width))
             (prescolidx (floor (* pres-width x) 1))
             (new-config-cols
              (if (zp prescolidx)
                (add-to-front (cons whose-turn nil) config-cols)
                (let ((usedcolidx (- prescolidx 1)))
                  (if (< usedcolidx used-width)
                    (add-to-end-of-nth whose-turn
                                       config-cols
                                       usedcolidx)
                    (add-to-end (cons whose-turn nil) config-cols)))))
             (winner
              (find-4-sequence-any new-config-cols)))
        (cons (if (consp winner)
                winner
                (not whose-turn))
              new-config-cols)))))
)
(set-initial-configuration *initial-config*)
(set-configuration-presenter 'presenter)
(add-click-handler 'dropper)

(trace* add-to-end add-to-front)
(trace* add-to-end-of-nth)
(trace* find-4-sequence)
(trace* find-4-sequence-vertical)

(big-bang)