;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TicTacToe clisp version
;; with macro "with-gtk"
;; by T.Shido;  Wed, 26 May 2004 09:58:19 +0900
;; tested on clisp 2.33 and winXP
;; This is  a simple transration of the ProLog version into clsip
;;
;; !!!
;; Chage *gtk-server* according to your system before use.
;;------------------------------------------------
;;
;; NEEDS GTK-SERVER 1.1 BUILD 19!! The mainloop needs to be changed
;; in order to work with GTK-server 1.2.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; definition of "with-gtk"
;;; change *gtk-server* according to your system
(defvar *gtk-server* "C:\\bin\\gtk-server\\gtk-server.exe")
;; For Linux use this: (defvar *gtk-server* "/usr/local/bin/gtk-server")
(defvar *gtk-socket* 50000)

;; macro "let+fn" makes nested let with function, like
;;(let+fn func ((a0 a1 a2 a3) (b0 b1 b2 b3) (c0 c1 c2 c3)) &body body
;; is expanded to 
;; (let ((a0 (func a1)))
;;    (func a2)
;;    (func a3)
;;    (let ((b0 (func b1)))
;;      (func b2)
;;      (func b3)
;;      (let ((c0 (func c1)))
;;        (func c2)
;;        (func c3)
;;        ,@body)))
;;
(defmacro let+fn (fn argvs &body body)
  (if argvs
      `(let ((,(first (car argvs)) (,fn ,@(second (car argvs)))))
	 ,@(mapcar #'(lambda (x) `(,fn ,@x))
		   (nthcdr 2 (car argvs)))
	 (let+fn ,fn ,(cdr argvs) ,@body))
    `(progn ,@body)))

;; 
(defmacro with-gtk (widgets &body body)
  (let ((socket (gensym)))
    `(let ((,socket (gtk-start *gtk-server* *gtk-socket*)))  ;connect to the gtk-server

;; gtk is defined in a closure, so that it refers socket.
;; gtk can be used like "format" function
       (defun gtk (&rest av)                
	 (princ (apply #'format nil av) ,socket)
	 (read-line ,socket))
       
       (gtk "gtk_init(NULL, NULL)")      ; initialize
       (let+fn gtk ,widgets ,@body)      ; use let+fn to make a nested let
       (princ "gtk_exit(0)" ,socket))))  ;terminate


;; Start the gtk-server and returns the socket
;; (gtk-start *gtk-server* *gtk-socket*)
(defun gtk-start (server nsocket) ;
  (ext:run-program server :arguments (list "tcp" (format nil "localhost:~D" nsocket)) :wait nil)
  (sleep 1) ; Wait a little so the server can initialize
  (socket:socket-connect nsocket))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;;;           TicTacToe


;; variables used in TicTacToe
(defvar *tic-board* (make-array 9))

;;;;;;;;;;;;;;;;;
;; macros used in this script

;; loop 
(defmacro for ((v s e &optional (step 1)) &body body)
  (let ((ge (gensym)))
    `(do ((,v ,s (+ ,v ,step)) (,ge ,e)) ((> ,v ,ge))
	  ,@body)))

;;
;; as function "gtk" works only in "with-gtk", following three macros
;; "mark-panel", "game-over-p", and "tic-new" should be defined as macros
;;
;; mark panel and update the *tic-table*	    
(defmacro mark-panel (u c)
  (let ((gc (gensym)))
    `(let ((,gc ,c))  ; 0, user; 1, pc
       (setf (aref *tic-board*  ,gc) ,u)  ; set value to the array
       ;show the mark to the GUI
       (gtk "gtk_label_set_text(~A, ~A)" (aref *tlabels ,gc) ,(if (= u 0) "X" "O")))))


;;  if the game over, show it
(defmacro game-over-p ()
  (let ((ge (gensym)))
    `(let ((,ge (tic-endp)))
       (if ,ge
	   (gtk "gtk_label_set_text(~A, ~A)"
		labelstatus
		(case ,ge
		 (0 "X won!")
		 (1 "O won!")
		 (2 "EVEN!")))
	 nil))))

;; start a new game	 
(defmacro tic-new ()
  `(when (< 0 (parse-integer (gtk "gtk_server_callback(~A)"  button2)))
     (for (i 0 8)
	  (setf (aref *tic-board* i) nil)
	  (gtk "gtk_label_set_text(~A, )" (aref *tlabels i)))
     (gtk "gtk_label_set_text(~A,-NEW-)" labelstatus)
     (gtk "gtk_widget_grab_focus(~A)" entry)))
 
	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; functions

;; compare arguments and return 't if they are same else nil.
(defun all-eql (o0 &rest ls0)
  (if ls0
      (dolist (o ls0 t)
	(or (eql o o0) (return-from all-eql nil)))
    t))

;; get coordination from the string from 'entry
;; if wrong input, it returns nil
(defun tic-get-cord (s)
  (let ((c (cond
	    ((find s '("1a" "a1") :test #'equal) 0)
	    ((find s '("1b" "b1") :test #'equal) 1)
	    ((find s '("1c" "c1") :test #'equal) 2)
	    ((find s '("2a" "a2") :test #'equal) 3)
	    ((find s '("2b" "b2") :test #'equal) 4)
	    ((find s '("2c" "c2") :test #'equal) 5)
	    ((find s '("3a" "a3") :test #'equal) 6)
	    ((find s '("3b" "b3") :test #'equal) 7)
	    ((find s '("3c" "c3") :test #'equal) 8)
	    (t nil))))
    (if c
	(if (aref *tic-board* c) nil c)  ; if the panel is already occupied return nil
      nil)))

;; check if the game over
(defun tic-endp ()
  (for (i 0 8 3)    ;check row
       (let ((s (aref *tic-board* i)))
	 (and s (all-eql s (aref *tic-board* (+ i 1)) (aref *tic-board* (+ i 2)))
	      (return-from tic-endp s))))
  (for (i 0 2)    ;check column
       (let ((s (aref *tic-board* i)))
	 (and s (all-eql  s (aref *tic-board* (+ i 3)) (aref *tic-board* (+ i 6)))
	      (return-from tic-endp s))))
  (let ((s (aref *tic-board* 4))) ;check diagonal 
    (and s
	 (or (all-eql s (aref *tic-board* 0) (aref *tic-board* 8))
	     (all-eql s (aref *tic-board* 2) (aref *tic-board* 6)))
	 (return-from tic-endp s)))
  (for (i 0 8) ;check if empty panels are
       (or (aref *tic-board* i) (return-from tic-endp nil)))
  2) ; 2 means 'even

;; this function find a row, column, or diagonal, in which
;; 'n member have value 'p and the rest have value nil,
;; then it returns the position of nil
(defun tic-sboard (p n)
  (let ((position nil) (m (- 3 n)))
      (for (i 0 8 3)        ;check row
	   (let ((nemp 0) (nocup 0))
	     (for (j 0 2)
		  (unless (aref *tic-board* (+ i j))  (incf nemp) (setq position (+ i j)))
		  (and (eql (aref *tic-board* (+ i j)) p) (incf nocup)))
	     (and (= nemp m) (= nocup n) (return-from tic-sboard position))))

    (for (i 0 2)        ;check column
	 (let ((nemp 0) (nocup 0))
	   (for (j 0 8 3)
		(unless (aref *tic-board* (+ i j))  (incf nemp) (setq position (+ i j)))
		(and (eql (aref *tic-board* (+ i j)) p) (incf nocup)))
	   (and (= nemp m) (= nocup n) (return-from tic-sboard position))))

    (let ((nemp 0) (nocup 0))
      (for (i 0 8 4)        ;check diagonal
	   (unless (aref *tic-board* i) (incf nemp) (setq position i))
	   (and (eql (aref *tic-board* i) p) (incf nocup)))
      (and (= nemp m) (= nocup n) (return-from tic-sboard position)))

    (let ((nemp 0) (nocup 0))
      (for (i 2 6 2)        ;check diagonal                                        
	   (unless (aref *tic-board* i) (incf nemp) (setq position i))                 
	   (and (eql (aref *tic-board* i) p) (incf nocup)))
      (and (= nemp m) (= nocup n) (return-from tic-sboard position))))
  nil)


;; computer plays 
(defun O-move ()
  (or                 ;in tic-sboard, first argument represents computer (1) or user (0)
   (tic-sboard 1 2)   ;make 3 
   (tic-sboard 0 2)   ;block enemy  
   (tic-sboard 1 1)   ;make 2
   (dolist (i '(4 0 2 6 8 1 3 5 7))  ; if (aref *tic-board* i) is empty return i
     (or (aref *tic-board* i) (return-from O-move i))))) 

;; Design the GUI
(with-gtk ((win ("gtk_window_new(0)")
		("gtk_window_set_title (~A, GUN CLISP TicTacToe)" win) 
		("gtk_widget_set_usize(~A, 250, 200)" win))
	   (table ("gtk_table_new(70, 50, 1)")
		  ("gtk_container_add (~A, ~A)" win table))
	   (button1 ("gtk_button_new_with_label (Exit)")
		    ("gtk_table_attach_defaults(~A, ~A, 38, 49, 25, 37)" table button1))
	   (button2 ("gtk_button_new_with_label(New)")
		    ("gtk_table_attach_defaults(~A, ~A, 38, 49, 10, 22)" table button2))
	   (frame1 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 5, 15, 10, 25)" table frame1))
	   (frame2 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 15, 25, 10, 25)" table frame2))
	   (frame3 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 25, 35, 10, 25)" table frame3))
	   (frame4 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 5, 15, 25, 40)" table frame4))
	   (frame5 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 15, 25, 25, 40)" table frame5))
	   (frame6 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 25, 35, 25, 40)" table frame6))
	   (frame7 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 5, 15, 40, 55)" table frame7))
	   (frame8 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 15, 25, 40, 55)" table frame8))
	   (frame9 ("gtk_frame_new(0)")
		   ("gtk_table_attach_defaults(~A, ~A, 25, 35, 40, 55)" table frame9))
	   (coordx1 ("gtk_label_new(a)")
		   ("gtk_table_attach_defaults(~A, ~A, 5, 15, 1, 9)" table coordx1))
	   (coordx2 ("gtk_label_new(b)")
		   ("gtk_table_attach_defaults(~A, ~A, 15, 25, 1, 9)" table coordx2))
	   (coordx3 ("gtk_label_new(c)")
		   ("gtk_table_attach_defaults(~A,~A, 25, 35, 1, 9)" table coordx3))
	   (coordx4 ("gtk_label_new(1)")
		   ("gtk_table_attach_defaults(~A,~A, 1, 4, 10, 25)" table coordx4))
	   (coordx5 ("gtk_label_new(2)")
		   ("gtk_table_attach_defaults(~A,~A, 1, 4, 25, 40)" table coordx5))
	   (coordx6 ("gtk_label_new(3)")
		   ("gtk_table_attach_defaults(~A,~A, 1, 4, 40, 55)" table coordx6))
	   (labelmove ("gtk_label_new(Your move: )")
		   ("gtk_table_attach_defaults(~A,~A, 1, 15, 60, 70)" table labelmove))
	   (entry  ("gtk_entry_new()") 
		   ("gtk_table_attach_defaults (~A,~A, 17, 36, 60, 70)" table entry))
	   (labelstatus ("gtk_label_new(-New-)")
			("gtk_table_attach_defaults (~A,~A, 38, 49, 60, 70)" table labelstatus))) 

         ; labels
	   (let ((*tlabels (make-array 9)))
	     (do ((i 0 (1+ i)) (n 5 (+ n 10)))
		 ((= i 9))
	       (multiple-value-bind (y x)
		   (floor n 30)
		 (setf (aref *tlabels i) (gtk "gtk_label_new()"))
		 (gtk "gtk_table_attach_defaults (~A, ~A, ~D, ~D, ~D, ~D)"
		      table (aref *tlabels i) x (+ x 10) (+ 10 (* y 15)) (+ 25 (* y 15)))))
	    
	 ;initialize the GUI and array  "*tic-board*"  
	     (gtk "gtk_widget_show_all(~A)" win)
	     (gtk "gtk_widget_grab_focus(~A)" entry)
	     (for (i 0 8) (setf (aref *tic-board* i) nil))

;;;game routine
	     (loop
	       (gtk  "gtk_main_iteration()")  ; stop here and wait for event
	       (if                            ;exit from the TicTacToe
		   (or
		    (< 0 (parse-integer (gtk  "gtk_server_callback(~A)" button1)))
		    (< 0 (parse-integer (gtk  "gtk_server_callback(~A)" win))))
		   (return))

	    ;user moves
	       (unless (game-over-p)     ; if not finished
		
		;when something is given to the entry
		 (when (< 0 (parse-integer (gtk "gtk_server_callback(~A)"  entry)))
		   (let ((c (tic-get-cord (gtk "gtk_entry_get_text(~A)" entry))))
		     (gtk "gtk_editable_delete_text(~A, 0, -1)" entry)
		    
		    ; when correct input
		     (when c                   
		       (mark-panel 0 c)

		; computer moves
		       (unless (game-over-p)
			 (mark-panel 1 (O-move)))))))
	      
	      ; start a new game if you wish
	       (tic-new))))