;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; CSCI-4150 Introduction to Artificial Intelligence
; Assignment 2 Support code, version 1.2
; Copyright (C) 2002-2004 Wesley H. Huang.  All rights reserved.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; This support code is for printing sliding block puzzles where the
; blocks may be different sizes.  For this assignment, we will assume
; that the blocks are rectangular or are "L-shaped".  A few example
; sliding block puzzle states are included in this file.  Below is the
; printed representation of "example-a" that was produced by the
; "print-sbp" procedure.
;
; ****************************
; * /-------\ /--\ /--\ /--\ *
; * |AAAAAAA| |BB| |CC| |DD| *
; * |AAAAAAA| |BB| \--/ \--/ *
; * |AAAAAAA| |BB| /--\      *
; * |AAAAAAA| |BB| |EE|      *
; * \-------/ \--/ \--/      *
; * /-------\      /-------\ *
; * |FFFFFFF|      |GGGGGGG| *
; * \-------/      \-------/ *
; *      /-------\      /--\ *
; *      |HHHHHHH|      |JJ| *
; *      \-------/      \--/ *
; ****************************
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define example-1 '((A 	 A   empty   B 	 C)
		    (A 	 A   empty   B 	 D)
		    (E 	 F     F   empty G)
		    (E empty   G     G   G)))
(define example-a '((  A   A   B     C     D)
		    (  A   A   B     E   empty)
		    (  F   F empty   G     G)
		    (empty H   H   empty   J)))
(define example-b '((C B H H D)
		    (empty B empty E empty)
		    (F F A A empty)
		    (G G A A J)))
(define example-c '((  A   A   A     A   empty empty empty )
		    (  B   B empty   C     C     C     E )
		    (empty B   D     C     C     C     E )
		    (empty B empty empty   E     E     E)
		    (empty F   F   empty   E     E     E)))
(define example-d '((empty A empty   B)
		    (  C   C   C     B)
		    (  C   D   E     E)
		    (empty D   E     E)
		    (empty D   D   empty)
		    (empty D   D   empty)
		    (  F   F empty empty)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Here are the procedures that print the sliding block puzzle to the
; screen.  Probably not very interesting reading (particularly since I
; haven't commented it very thoroughly), but here it is in case you'd
; like to look at it.
; 

(define (print-sbp sbp)
  (if (not (valid-sbp? sbp))
      (error "Error: invalid sliding block puzzle state given to print-sbp.")
      (let ((header-string  (make-string (+ (* (length (car sbp)) 5) 3) #\*)))
	(display header-string)
	(newline)
	(psbp-helper (cons (make-list (length (car sbp))) sbp)
		     sbp
		     (append (cdr sbp) (list (make-list (length (car sbp))))))
	(display header-string)
	(newline))))


; print all the rows of the puzzle
;
; the three arguments must be lists of all the rows such that the
; first element of each correspends to the previous, current, and next
; row to be printed.  For the first element of "prev-rows" on the
; initial call, a list (of the proper length) of any elements can be
; used so long as they won't match any of the blocks.  A list of
; 'nulls' would suffice.  (You have to look at the row above and below
; to figure out how to print the current row.)
; 
(define (psbp-helper prev-rows this-rows next-rows)
  (cond ((not (null? this-rows))
	 (psbp-print-row (psbp-rowstrings '() '() '()
					  (car prev-rows)
					  (car this-rows)
					  (if (null? next-rows)
					      (make-list
					       (length (car this-rows)))
					      (car next-rows))))
	 (psbp-helper (cdr prev-rows) (cdr this-rows) (cdr next-rows)))))
    
; print a row given the three strings corresponding to the three lines
; of the "body" of that row.
; 
(define (psbp-print-row str-list)
  (display "* ")
  (display (first str-list))
  (display "*\n* ")
  (display (second str-list))
  (display "*\n* ")
  (display (third str-list))
  (display "*\n"))

; since a block A can be represented by either the symbol A or the
; list (A), this procedure is handy for determining whether two cells
; are occupied by the same block.
; 
(define (same-block? x y)
  (or (equal? x y)
      (equal? (list x) y)
      (equal? x (list y))))

; Each row corresponds to three printed lines.  This procedure
; generates strings for those three lines (not including the puzzle
; border).  They are returned in a list.
;
; This is done by generating the strings for the first cell, then
; appending these strings to the three strings returned by a recursive
; call for the rest of the cells.  Each cell corresponds to 5
; characters (or more accurately, 5 columns of characters.
; 
(define (psbp-rowstrings prev-left-el this-left-el next-left-el
			 prev-row this-row next-row)
  (cond ((null? this-row)		; base case
	 '("" "" ""))
	((equal? (car this-row) 'empty)	; if empty, then we just need sapces
	 (map string-append
	      (make-list 3 (make-string 5 #\space))
	      (psbp-rowstrings (car prev-row) (car this-row)
			       (car next-row) (cdr prev-row)
			       (cdr this-row) (cdr next-row))))
	(else ; create the strings for a row
         ; first let's have some local variables that tell us whether the
	 ; neighboring cells are part of the same block
	 (let ((thisblock (car this-row)))
	   (let ((NW (same-block? prev-left-el thisblock))
		 (W (same-block? this-left-el thisblock))
		 (SW (same-block? next-left-el thisblock))
		 (N (same-block? (car prev-row) thisblock))
		 (S (same-block? (car next-row) thisblock))
		 (NE (same-block? thisblock
				  (if (null? (cdr prev-row))
				      '()
				      (second prev-row))))
		 (E (same-block? thisblock
				 (if (null? (cdr this-row))
				     '()
				     (second this-row))))
		 (SE (same-block? thisblock
				  (if (null? (cdr next-row))
				      '()
				      (second next-row))))
		 (blockstr (string-capitalize
			    (symbol->string (if (list? (car this-row))
						(caar this-row)
						(car this-row))))))
	     ; create strings for each column --- these will be lists
	     ; of three strings, each one character long.  The middle
	     ; column will be repeated twice.
	     (let ((rightcol (psbp-rightcol NW N NE W E SW S SE blockstr))
		   (middlecol (psbp-middlecol NW N NE W E SW S SE blockstr))
		   (leftcol (psbp-leftcol NW N NE W E SW S SE blockstr))
		   (spacecol (psbp-spacecol NW N NE W E SW S SE blockstr)))
	       (map string-append
		    leftcol
		    middlecol
		    middlecol
		    rightcol
		    spacecol
		    (psbp-rowstrings (car prev-row) 
				     (car this-row)
				     (car next-row)
				     (cdr prev-row)
				     (cdr this-row)
				     (cdr next-row)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; the following procedures create the "columns" for a cell.  A
; solitary cell consists of four columns with the fifth column being
; spaces.  An ASCII border is drawn around the cell, and the letter of
; the cell appears in the inner 2x2 block of the printed
; representation.  What characters are drawn for the border depends on
; whether neighboring cells are covered by the same block, in which
; case the border on some sides may be replaced by the block letter.
; The character for the a corner will depend on how the boundary will
; be extended for non-unit cells.  The column of spaces may also be
; filled in to print a block spanning horizontally adjacent cells.
; 
(define (psbp-leftcol NW N NE W E SW S SE blockstr)
  (list (cond ((and N NW W) blockstr)
	      ((and N W) "+")
	      (W "-")
	      (N "|")
	      (else "/"))
	(if W
	    blockstr
	    "|")
	(cond ((and S SW W) blockstr)
	      ((and S W) "+")
	      (W "-")
	      (S "|")
	      (else "\\"))))

(define (psbp-middlecol NW N NE W E SW S SE blockstr)
  (list (if N
	    blockstr
	    "-")
	blockstr
	(if S
	    blockstr
	    "-")))

(define (psbp-rightcol NW N NE W E SW S SE blockstr)
  (list (cond ((and N NE E) blockstr)
	      ((and N E) "+")
	      (E "-")
	      (N "|")
	      (else "\\"))
	(if E
	    blockstr
	    "|")
	(cond ((and S SE E) blockstr)
	      ((and S E) "+")
	      (E "-")
	      (S "|")
	      (else "/"))))

(define (psbp-spacecol NW N NE W E SW S SE blockstr)
  (list (cond ((and N NE E) blockstr)
	      (E "-")
	      (else " "))
	(if E
	    blockstr
	    " ")
	(cond ((and S SE E) blockstr)
	      (E "-")
	      (else " "))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; determine whether a sliding block puzzle state is (syntactically) valid
(define (valid-sbp? s)
  (and (list? s)			; it's a list
       (not (null? s))			; not empty
       (all-true (map list? s))		; all elements are list
       (apply = (map length s))		; all element lists are same length
       (all-true (map valid-row? s))))	; all rows are valid

(define (valid-row? r)
  (all-true (map (lambda (e) (or (equal? e 'empty)
				 (and (symbol? e)
				      (= 1 (string-length
					    (symbol->string e))))
				 (and (list? e)
				      (= (length e) 1)
				      (= 1 (string-length
					    (symbol->string (car e)))))))
		 r)))

; return true if all elements of Lst are #t
(define (all-true Lst)
  (if (null? Lst)
      #t
      (and (car Lst) (all-true (cdr Lst)))))