;;;  TURTLE WORLD
;;;
;;;  Simple program to run a turtle in a 2 dimensional world while performing selected behaviors
;;;
;;;		1. go around obstacles. 
;;;		2. labyrinth (it can take a lot of time). 		 
;;;		3. follow light 
;;;		4. follow small animals (or obstacles such as balls). 
;;;		5. avoid large animals (or obstacles such as big blocks). 
;;;		6. try to be in crowd. 
;;;		7. avoid crowd. 
;;;	   	8. avoid light
;;;		9. go to goal position specified by two coordinates (exact) or one cordinate (as far as you can go to North). 
;;;		use as little energy as possible (go to any direction as far as you can from the start using your given initial total energy). 
;;;
;;;
;;;   To run this program use harlequien lispworks from http://www.xanalys.com/software_tools/products/index.html
;;;
;;;	  load and compile this file.   type (tw::run-world [option])   --- option is 1,4
;;;
;;;	  







(defpackage "ANTS" (:use "COMMON-LISP" "CAPI"))
(in-package "ANTS")

(defconstant PI 3.1415)
(defconstant LATERAL-SENSOR-LONG-THRESHOLD 30)
(defconstant FORWARD-SENSOR-SHORT-THRESHOLD 30)
(defconstant ANGULAR-ROTATION-RATE (* (/ 5 360) (* 2 PI)))

;;; --------------------
;;; constants
;;; --------------------
(setq small-size 20)
(setq large-size 50)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define the world objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq ant-proto '(
			(name .  ant)
			(obj-type . animal)
			(obj-shape . circle)
			(animal . ant)
			(ant-type . worker)
			(behavior . FindFood )
			(movement-state . GoTowardsGoal)
		   	(speed . .5)
			(xpos . 10) 
			(ypos . 10)
			(pre-xpos . 11)
			(pre-ypos . 11)
			(orientation . 1.2 )
			(goal-xpos . 100 ) 
			(goal-ypos . 20 )
			(waypoint-xpos . 0 )
			(waypoint-ypos . 0 )
			(size . 10)
			(color . :red)	
			(goal . 0) 	
			(sensor-range . 40 )
			(sensor-end . .785375)
			(sensor-start .  -.785375)
			(sensor-number . 3 )
			(sensor-resolution . 10)
			(sensor-reading . 0)
			(found-goal . NIL)
			(partner . NIL)
			(debug-state . NIL)
			))


(setq bouncer-proto '(
			(name .  bouncer)
			(obj-type . animal)
			(obj-shape . circle)
			(animal . ant-eater)
    		(behavior . Random )
			(movement-state . GoTowardsGoal)
		   	(speed . 1.5)
			(xpos . 10) 
			(ypos . 480)
			(pre-xpos . 11)
			(pre-ypos . 481)
			(orientation . 1.2 )
			(goal-xpos . 100 ) 
			(goal-ypos . 20 )
			(waypoint-xpos . 0 )
			(waypoint-ypos . 0 )
			(size . 20)
			(color . :black)	
			(goal . 0) 	
			(sensor-range . 40 )
			(sensor-end . .785375)
			(sensor-start .  -.785375)
			(sensor-number . 3 )
			(sensor-resolution . 10)
			(sensor-reading . 0)
			(found-goal . NIL)
			(partner . NIL)
			(debug-state . NIL)
			))



(setq antnest '( 
			(name . Antnest)
			(obj-type . stationary)
			(obj-shape . circle)
			(xpos . 480) 
			(ypos . 480)
			(pre-xpos . 481)
			(pre-ypos . 481)
			(size . 10)
			(color . :blue)
			))


(setq square-proto '( 
			(name . Table )
			(obj-type . stationary)
			(obj-shape . rectangle)
			(xpos . 310) 
			(ypos . 350)
			(x2pos . 410)
			(y2pos . 410)
			(pre-xpos . 241)
			(pre-ypos . 200)
			(length . 20 ) 
			(width . 15)
			(size . 20)
			(color . black)
			))


(setq walls '(
			(name . Walls )
			(obj-type . stationary )
			(obj-shape . wall )
			(xsize . 500 )
			(ysize . 500 )
			(color . blue )))



	     

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; World definition and execution loops
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defun run ()
  	(progn 
				
				
			   	(setq world-objects (list walls antnest))

				(init-graphics-pane)



				;;Wait right here until the user releases the pause button
				(loop while (simulation-paused) do (+ 2 2))
				
			   
				;; Add some ants
				(setq ants (create-ant-nest 12))
				(setq world-objects (append world-objects ants))

				;; Add some bouncers
    			(setq bouncers (create-bouncers 2))
				(setq world-objects (append world-objects bouncers))

			  


				;; need to display the ant nest
				(set-value 'obj-type antnest 'mobile)
				(show-obj antnest)
				(set-value 'obj-type antnest 'stationary)
						
				(simulate world-objects)))

				

(defun initialize-ant (ant type)
  (progn
	   (set-value 'ypos ant 20)
	   (set-value 'xpos ant 20)
	   (set-value 'goal ant (find-nearest-object ant 'food))
	   (set-value 'orientation ant (get-orientation-towards-goal ant))
	   (set-value 'ant-type ant type)))


(defun create-ant-nest (number-ants)
	(loop for ant from 1 by 1 to number-ants collect
		(initialize-ant (copy-alist ant-proto) 'worker)))

(defun create-bouncers (number-bouncers)
	(loop for bouncer from 1 by 1 to number-bouncers collect
		(copy-alist bouncer-proto)))

  				




(defun simulate (list_of_objects)
	(loop while (simulation-not-stopped) do
		(progn
			(loop while (simulation-paused) do (+ 2 2))
			(setq list_of_objects (one_step_of_world list_of_objects))
    	) 
    )
)

(defun one_step_of_world (list_of_objects)
    (mapcar #'show-obj list_of_objects)
	(mapcar #'move-obj list_of_objects))

(defun debug-show-move-obj (object)
	(progn
		(move-obj object)
		(show-obj object)
		(describe object)))
		
	


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Collision Detection Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun detect-collision (object list_of_objects)
    (cond 
	((eq list_of_objects NIL) NIL)
	((eq (get-value 'name object) (get-value 'name (car list_of_objects))) (detect-collision object (cdr list_of_objects)))  ;;; don't detect yourself
  	((eq (get-value 'obj-shape (car list_of_objects)) 'wall)
		(if (collided-walls? object (car list_of_objects))
			(cons (car list_of_objects) (detect-collision object (cdr list_of_objects))) 	;;; collisiion
			(detect-collision object (cdr list_of_objects))))	;;; no collision this time			
  	((and (eq (get-value 'obj-shape (car list_of_objects)) 'circle) 
		  (eq (get-value 'obj-shape object) 'circle)) 
		  (if  (collided-circles? object (car list_of_objects)) 
				(cons (car list_of_objects) (detect-collision object (cdr list_of_objects))) 	;;; collisiion
				(detect-collision object (cdr list_of_objects))))	;;; no collision this time
	((and (eq (get-value 'obj-shape (car list_of_objects)) 'rectangle) 
		  (eq (get-value 'obj-shape object) 'circle)  ) 
		  (if  (collided-rectangle? object (car list_of_objects)) 
				(cons (car list_of_objects) (detect-collision object (cdr list_of_objects))) 	;;; collisiion
				(detect-collision object (cdr list_of_objects))))	;;; no collision this time
  	(t (detect-collision object (cdr list_of_objects)))))

(defun collided-circles? (obj1 obj2)
	(< (distance-obj obj1 obj2) (+ (get-value 'size obj1) (get-value 'size obj2)))) 
				
(defun collided-walls? (object walls)
	(or 
		(< (get-value 'xpos object) 0) 
		(< (get-value 'ypos object) 0)
		(> (get-value 'xpos object) (get-value 'xsize walls))
		(> (get-value 'ypos object) (get-value 'ysize walls))))
		 
(defun collided-rectangle? (object rect)
	 (and 
		(> (+ (get-value 'xpos object) (get-value 'size object)) (get-value 'xpos rect))
		(> (+ (get-value 'ypos object) (get-value 'size object)) (get-value 'ypos rect))
		(< (- (get-value 'xpos object) (get-value 'size object)) (get-value 'x2pos rect))
		(< (- (get-value 'ypos object) (get-value 'size object)) (get-value 'y2pos rect))))
	  
;;; square root of the squares
(defun distance-obj (obj1 obj2)
   (sqrt (+ 
   (*	(- (cdr (assoc 'xpos obj1)) (cdr (assoc 'xpos obj2))) 
		(- (cdr (assoc 'xpos obj1)) (cdr (assoc 'xpos obj2))))
   (*	(- (cdr (assoc 'ypos obj1)) (cdr (assoc 'ypos obj2))) 
		(- (cdr (assoc 'ypos obj1)) (cdr (assoc 'ypos obj2)))))))
	


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Movement utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun next-move (object)
	(set-value 'pre-xpos object (get-value 'xpos object))
	(set-value 'pre-ypos object (get-value 'ypos object))
	(set-value 'xpos object (+ (get-value 'xpos object) (* (cos (get-value 'orientation object)) (get-value 'speed object))))
	(set-value 'ypos object (+ (get-value 'ypos object) (* (sin (get-value 'orientation object)) (get-value 'speed object))))

	(if t object object))

(defun display-object (object)
	(print (cdr (assoc 'name object)))
	(print (cdr (assoc 'xpos object))))


(defun move-obj (object)
	(if  (eq (get-value 'obj-type object) 'animal) 
		(cond 
			((eq (get-value 'behavior object) 'Random) (move-obj-random object))
	   		((and (eq (get-value 'behavior object) 'FindFood) (found-goal? object))
	   			 (progn
	   			 	(set-value 'behavior object 'WaitForPartner)
	   			 	(move-obj-toward-goal object)))
			((eq (get-value 'behavior object) 'FindFood) (move-obj-toward-goal object))
	   		((and (eq (get-value 'behavior object) 'WaitForPartner) (found-goal? object))
	   			(let ((partner (find-nearest-object object 'ant)))
				  (progn 
	   				(if (and (eq (get-value 'behavior partner) 'FindFood)
	   						 (< (distance-obj object partner) (get-value 'sensor-range object))
	   						 (found-goal? partner))
	   					(progn
							(set-value 'partner     object partner)
	   						(set-value 'goal 		object antnest)
	   						(set-value 'behavior 	object 'FindNest)
							(set-value 'movement-state object 'GoTowardsGoal)
	   						(set-value 'goal 		partner object)
							(set-value 'movement-state partner 'GoTowardsGoal)
	   						(set-value 'behavior 	partner 'FollowPartner)))
	   				(move-obj-toward-goal object)
	   			  )
	   			)
	   		)
			((eq (get-value 'behavior object) 'WaitForPartner)
				(progn
					(set-value 'behavior object 'FindFood)
				    (move-obj-toward-goal object)))
	   		((eq (get-value 'behavior object) 'FollowPartner) (move-obj-toward-goal object))
	   		((and (eq (get-value 'behavior object) 'FindNest) (found-goal? object))
	   			 (let ((partner (get-value 'partner object)))
	   				(progn 
	   					(set-value 'goal 		object (find-nearest-object object 'food))
	   					(set-value 'behavior    object 'FindFood)
						(set-value 'movement-state object 'GoTowardsGoal)
	   					(set-value 'goal 		partner (find-nearest-object object 'food))
						(set-value 'movement-state partner 'GoTowardsGoal)
	   					(set-value 'behavior    partner 'FindFood)
	   			 		(move-obj-toward-goal object))))	
	   		((eq (get-value 'behavior object) 'FindNest) (move-obj-toward-goal object)))	
							
		(if t object object)))	 
(defun move-obj-random (object)
   	(if (detect-collision (next-move (copy-alist object)) world-objects )
		(set-random-orientation object)
		(next-move object)))

(defun move-obj-toward-goal (object)
    (if 
 	    (and (exist-path-toward-goal? object) 
		  (not (backtracking? object)))
 			(progn
				(set-value 'found-goal object (found-goal? object))
 				(set-value 'movement-state object 'GoTowardsGoal)
 				(set-value 'orientation object (get-orientation-towards-goal object))
 				(next-move object))
 	 (cond
		((eq (get-value 'movement-state object) 'GoTowardsGoal)
			(if (eq (random 2) 0) 
				(set-value 'movement-state object 'FollowLeft)
				(set-value 'movement-state object 'FollowRight)))
		(t 
			(progn 		
				(set-value 'orientation object (get-orientation-to-follow-obstacle object ))
	    		(next-move object))))))

(defun found-goal? (object)
	(< (distance-obj object (get-value 'goal object)) (+ 10 (get-value 'sensor-range object))))

(defun backtracking? (object)
	(if (not (eq (get-value 'behavior object) 'FollowPartner))
		 (let ((tobject (copy-alist object))
			  (pobject (copy-alist object))
			  (goal-orientation    (mod (get-orientation-towards-goal object) (* 2 PI)))
			  (current-orientation (mod (get-value 'orientation object) (* 2 PI))))
		 (progn
			(set-value 'orientation tobject goal-orientation)
			(next-move tobject)
			(next-move tobject)
			(set-value 'xpos pobject (get-value 'pre-xpos object))
			(set-value 'ypos pobject (get-value 'pre-ypos object))
			(or (< (distance-obj tobject pobject) (distance-obj tobject object))
			    (and (< goal-orientation current-orientation) 
			    	 (> goal-orientation (mod (+ current-orientation PI) (* 2 PI)))))		
			))
		Nil))


	
(defun step-obj (object count)
	(if (> count 0)
		(progn
			(move-obj object)
			(show-obj object)
			(describe object)
			(step-obj object (- count 1)))))
		
					

		
(defun get-orientation-to-follow-obstacle (object)
	(let ((direction (if (eq (get-value 'movement-state object) 'FollowLeft) -1 1)))		
		(cond 
			;Turn towards the obstacle if we are following it and we are too far away 
			( (> (get-lateral-sensor-reading object) LATERAL-SENSOR-LONG-THRESHOLD)
			  (+ (get-value 'orientation object) (* direction ANGULAR-ROTATION-RATE)))
			
			;If there is an obstacle in front of us rotate so that we keep the object
			;  to the selected lateral (left,right) flank. 
			( (< (get-forward-sensor-reading object) FORWARD-SENSOR-SHORT-THRESHOLD)
			  (progn
    			(loop while (< (get-forward-sensor-reading object) FORWARD-SENSOR-SHORT-THRESHOLD) 
					do 
		 			(set-value 'orientation object 
					 (+ (get-value 'orientation object) (* (* -1 direction) ANGULAR-ROTATION-RATE))))
			    (if t (get-value 'orientation object))))
			(t 
				(get-value 'orientation object))	
				
				
		)
	)
)
		

(defun get-forward-sensor-reading (object)
  	(progn
			(setf ping-object (copy-alist object))
			(set-value 'size ping-object  (get-value 'sensor-resolution object))
			(set-value 'speed ping-object (get-value 'sensor-resolution object))
			(get-radial-sensor-reading object ping-object)))			


(defun get-lateral-sensor-reading (object)
	(let ((sweep (get-sensor-sweep object)))
		(if (eq (get-value 'movement-state object) 'FollowLeft) 
			(car sweep) 
			(caddr sweep))))

(defun vmax (sweep)
	(if (eq (cdr sweep) nil) (car sweep)
		(max (car sweep) (vmax (cdr sweep)))))


(defun dialate-object (object value)
	(set-value 'size object (* value (get-value 'size object))))

(defun rotate-object (object rotation-amount)
	(set-value 'orientation object (+ rotation-amount (get-value 'orientation object))))

(defun get-orientation-towards-goal (object)
	(atan   (- (get-value 'ypos (get-value 'goal object)) (get-value 'ypos object))
			(- (get-value 'xpos (get-value 'goal object)) (get-value 'xpos object) )))

(defun set-random-orientation (object)
		(set-value 'orientation object (* 2 (* pi (/ (random 100) 100))))
		(if t object object))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Behaviors utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun find-nearest-object (object name)
	(let ( (distance 5000) 
			(wlist world-objects) 
			(result NIL))
	(progn
		(loop while (not (eq (car wlist) NIL)) do
		 (progn
		  	(if (and (eq (get-value 'name (car wlist) ) name)
				(< (distance-obj (car wlist) object) distance)
				(not (eq (get-value 'xpos (car wlist)) (get-value 'xpos object)))
				(not (eq (get-value 'ypos (car wlist)) (get-value 'ypos object))))

					(progn
						(setf result (car wlist))
						(setf distance (distance-obj (car wlist) object))))
			(setq wlist (cdr wlist))))
		(if t result )  )))		 





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sensor utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun exist-path-toward-goal? (object)
	 ;;; search the sensor readings and determine if the direction is clear
	 ;;; assumes for now that the goal is always within the angular capture range
	 ;;; of the sensors.  This needs to be fixed for more complicated cases.
	 ;;;
	 ;;; FIX ME FOR A REAL ROBOT -- I just read a sensor which does not exsist
	  (progn
			(setq ping-object (copy-alist object))
			(set-value 'size ping-object  (get-value 'sensor-resolution object))
			(set-value 'speed ping-object (get-value 'sensor-resolution object))
			(set-value 'orientation ping-object (get-orientation-towards-goal object)) 
			(= (get-radial-sensor-reading object ping-object) (get-value 'sensor-range object))
			  	
	 ))			
	
	
(defun get-sensor-sweep (object)
	   (let (
	   	  (end-angle (get-value 'sensor-end object))
		  (start-angle (get-value 'sensor-start object))
		  (angular-step (/ (- (get-value 'sensor-end object) (get-value 'sensor-start object))
							(- (get-value 'sensor-number object) 1)))) 
		 (loop for angle from start-angle by angular-step to end-angle collect
		  	(progn
				(setq ping-object (copy-alist object))
				(set-value 'size ping-object  (get-value 'sensor-resolution object))
				(set-value 'speed ping-object (get-value 'sensor-resolution object))
				(set-value 'orientation ping-object 
					(+ (get-value 'orientation object) angle)) 
				(get-radial-sensor-reading object ping-object)
		  	)			
		 )))

 

(defun get-radial-sensor-reading (object ping-object)
	(cond
		;;case where we have collided with something in the world
		((detect-collision (next-move ping-object) world-objects)
		  (min (get-value 'sensor-range object) (distance-obj ping-object object)))

		;;case where we have extended beyond sensor range  -- return range
		((> (distance-obj ping-object object) (get-value 'sensor-range object ))
			(get-value 'sensor-range object))

		;;case where we continue along the radial line
		(t (get-radial-sensor-reading object (next-move ping-object)))
		
		))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Graphic Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun show-obj (object)
	(if (eq (get-value 'obj-type object) 'stationary) ()
	(if
   	   (eq (get-value 'obj-shape object) 'circle)
				(progn
				(gp:draw-circle display-pane 
					(get-value 'pre-xpos object)
					(get-value 'pre-ypos object)
							(get-value 'size object)
					:filled t
					:foreground :white )
				(gp:draw-circle display-pane 
					(get-value 'xpos object)
					(get-value 'ypos object)
					(get-value 'size object)
						:filled t
						:foreground (get-color-object object))   )
	 (if
	 	(eq (get-value 'obj-shape object) 'rectangle)
	 		(progn
	 		(gp:draw-rectangle display-pane 
	 			(get-value 'xpos object)
	 			(get-value 'ypos object)
	 			(- (get-value 'x2pos object) (get-value 'xpos object))
	 			(- (get-value 'y2pos object) (get-value 'ypos object))
	 			:filled t
	 			:foreground :blue ) ) ) 
				
						
						  )  						
	)
)

(defun get-color-object (object)
 	(if (eq (get-value 'name object) 'ant)
	(cond
	   ;;	((eq (get-value 'movement-state object) 'FollowLeft) :pink)
	   ;;	((eq (get-value 'movement-state object) 'FollowRight) :purple)
		((eq (get-value 'behavior object) 'FindFood) :red)
		((eq (get-value 'behavior object) 'FindNest) :green)
		((eq (get-value 'behavior object) 'WaitForPartner) :blue)
		((eq (get-value 'behavior object) 'FollowPartner) :orange))
	(get-value 'color object)))



				   
;(setq output-pane
;	(contain
;		(make-instance 'output-pane
;				:best-width 300
;				:best-height 300)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Object Manipulations Utility Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-value (key object)
	(cdr (assoc key object)))

(defun set-value (key object value)
	(progn
		(setf (cdr (assoc key object)) value)
		(if t object)))

(defun add-object-to-world (name x y x2 y2)
	(progn
		(setq temp-square (copy-alist square-proto))
		(set-value  'xpos 	temp-square	  (min x x2))
		(set-value  'ypos 	temp-square	  (min y y2))
		(set-value  'x2pos	temp-square	  (max x x2))
		(set-value  'y2pos	temp-square	  (max y y2))
		(set-value 	'name   temp-square	  name)
		(setq world-objects (append world-objects (list temp-square)))))

		 



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; UI Functions
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun simulation-not-stopped ()
	(or 
		(eq 'go (pinboard-test-mode global-pinboard-test))
		(eq 'pause (pinboard-test-mode global-pinboard-test)))) 
 

(defun simulation-paused ()
	(eq 'pause (pinboard-test-mode global-pinboard-test)))

;;----------------------------------------------------------------------------
;;
;; examples/capi/graphics/pinboard-test.lisp
;;
;; This example demonstrates the uses of pinboard-objects and
;; pinboard-layouts in the CAPI.
;;
;; To try it, compile and load this file and then execute:
;;
;;      (CL-USER::TEST-PINBOARD)
;;
;;----------------------------------------------------------------------------
;; Copyright (c) 1987--98 Harlequin Group plc. All rights reserved.
;;----------------------------------------------------------------------------

;;----------------------------------------------------------------------------
;; Define an interface
;;----------------------------------------------------------------------------

(capi:define-interface pinboard-test ()
  ((new-class :accessor new-class :initform nil)
   (start-x :accessor start-x)
   (start-y :accessor start-y)
   (last-x :accessor last-x)
   (last-y :accessor last-y))
  (:panes
   (mode-buttons
    capi:radio-button-panel
    :accessor mode-buttons
    :title "Action:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(Pause Stop Go)
    :print-function 'string-capitalize)
   (object-buttons
    capi:radio-button-panel
    :accessor object-buttons
    :title "Object:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(food obstacle)
    :print-function 'string-capitalize)
   (style-buttons
    capi:radio-button-panel
    :accessor style-buttons
    :title "Style:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(:solid :outline)
    :print-function 'string-capitalize))
  (:layouts
   (pinboard
    capi:pinboard-layout
    '()
    :background :white
    :input-model '(((:button-1 :press)   press-button-1)
                   ((:motion :button-1)  drag-button-1)
                   ((:button-1 :release) release-button-1)
                   ((:button-2 :press)   press-button-2))
    :drawing-style (:initarg :display-type)
    :vertical-scroll t
    :horizontal-scroll t
    :min-width 500
    :min-height 500)
   (button-layout
    capi:column-layout
    '(mode-buttons object-buttons style-buttons)
    :y-gap 10)
   (sub-layout
    capi:column-layout
    '(pinboard)
    :title "Drag button 1 to add an object and button 2 to delete one")
   (main-layout
    capi:row-layout
    '(button-layout sub-layout)
    ))
  (:default-initargs
   :layout 'main-layout
   :title "Pinboard Test"
   :best-height 500
   :best-width 500))

(defun pinboard-test-object (pinboard-test)
  (capi:choice-selected-item (object-buttons pinboard-test)))

(defun pinboard-test-filled (pinboard-test)
  (eq (capi:choice-selected-item (style-buttons pinboard-test)) :solid))

(defun pinboard-test-mode (pinboard-test)
  (capi:choice-selected-item (mode-buttons pinboard-test)))


;;----------------------------------------------------------------------------
;; A few useful utilities
;;----------------------------------------------------------------------------

;; x-y-width-and-height is a simple function which given two coordinates
;; returns the top-left x and y, and the width and height
(defun x-y-width-and-height (x1 y1 x2 y2)
  (values (min x1 x2)
          (min y1 y2)
          (abs (- x1 x2))
          (abs (- y1 y2))))

;; WITH-XOR makes all graphics-port operations done within its body be drawn
;; using exclusive-or.
(defmacro with-xor ((port) &body body)
  `(gp:with-graphics-state (,port
                            :foreground (gp:compute-xor-pixel ,port)
			    :operation boole-xor)
    ,@body))


;;----------------------------------------------------------------------------
;; Define a square pinboard-object
;;----------------------------------------------------------------------------

(defclass square (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (square square) &key)
  (capi:with-geometry square
    (let ((filled? (filled square)))
      (gp:draw-rectangle pinboard
                         capi:%x% capi:%y%
                         (if filled? capi:%width% (1- capi:%width%))
                         (if filled? capi:%height% (1- capi:%height%))
                         :foreground (or (foreground square)
				         (capi:simple-pane-foreground pinboard))
                         :filled filled?))))

(defmethod draw-object-outline (pinboard (square square) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (with-xor (pinboard)
      (gp:draw-rectangle pinboard x y width height))))


;;----------------------------------------------------------------------------
;; Define an ellipse pinboard object
;;----------------------------------------------------------------------------

(defclass ellipse (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (ellipse ellipse) &key)
  (capi:with-geometry ellipse
    (let ((x-radius (floor (1- capi:%width%) 2))
          (y-radius (floor (1- capi:%height%) 2)))
      (gp:draw-ellipse pinboard
		       (+ capi:%x% x-radius)
                       (+ capi:%y% y-radius)
                       x-radius
                       y-radius
		       :foreground (or (foreground ellipse)
                                       (capi:simple-pane-foreground pinboard))
                       :filled (filled ellipse)))))

(defmethod draw-object-outline (pinboard (ellipse ellipse) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (let ((x-radius (floor width 2))
          (y-radius (floor height 2)))
      (with-xor (pinboard)
        (gp:draw-ellipse pinboard 
			 (+ x x-radius)
			 (+ y y-radius)
			 x-radius
			 y-radius)))))


;;----------------------------------------------------------------------------
;; Define a text pinboard object
;;----------------------------------------------------------------------------

(defclass text (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (text text) &key)
  (capi:with-geometry text
    (let ((foreground (or (foreground text) (capi:simple-pane-foreground pinboard)))
          (background (capi:simple-pane-background pinboard))
          (filled (filled text)))
      (gp:draw-x-y-adjusted-string pinboard
                                   "This is a test."
		                   capi:%x%
		                   capi:%y%
                                   :y-adjust :top
                                   :foreground (if filled background foreground)
                                   :background (if filled foreground background)
                                   :block (filled text)))))

(defmethod draw-object-outline (pinboard (text text) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (with-xor (pinboard)
      (gp:draw-rectangle pinboard x y width height))))


;;----------------------------------------------------------------------------
;; The callbacks
;;----------------------------------------------------------------------------

(defun press-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (shape 'square))
    (setf (new-class interface) (clos:class-prototype (find-class shape)))
    (setf (start-x interface) x)
    (setf (start-y interface) y)
    (setf (last-x interface) nil)))

(defun drag-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (object (new-class interface)))
    (when (last-x interface)
      (draw-object-outline pinboard object
                           (start-x interface) (start-y interface)
                           (last-x interface) (last-y interface)))
    (setf (last-x interface) x
          (last-y interface) y)
    (draw-object-outline pinboard object
                         (start-x interface) (start-y interface)
                         (last-x interface) (last-y interface))))

(defun release-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (object (new-class interface))
         (old-x (start-x interface))
         (old-y (start-y interface))
         (color (if (eq (pinboard-test-object interface) 'food) :green :black))
         (filled (pinboard-test-filled interface))
         (width (abs (- old-x x)))
         (height (abs (- old-y y))))

	;; log the position of the object to the bug routine
	(add-object-to-world (pinboard-test-object interface) old-x old-y x y )
	(setf display-pane pinboard)



    ;; Remove the outline
    (when (last-x interface)
      (draw-object-outline pinboard object
                           (start-x interface) (start-y interface)
                           (last-x interface) (last-y interface)))

    ;; Create the appropriate pinboard-object and place it into
    ;; the pinboard-layout. We append it to the end of the list so
    ;; that it appears on top.
    (when (and (> width 1)
               (> height 1))
      (setf (capi:layout-description pinboard)
            (append (capi:layout-description pinboard)
                    (list
                     (make-instance (class-of object)
                                    :foreground color
                                    :filled filled
                                    :x (min old-x x)
                                    :y (min old-y y)
                                    :min-width  width
                                    :min-height height)))))))

(defun press-button-2 (pinboard x y)
  (let ((object (capi:pinboard-object-at-position pinboard x y)))
    (when object
      (setf (capi:layout-description pinboard)
            (remove object (capi:layout-description pinboard))))))


;;----------------------------------------------------------------------------
;; The test function
;;----------------------------------------------------------------------------

(defun init-graphics-pane ()
 (progn
  (setq global-pinboard-test (contain (make-instance 'pinboard-test :display-type :local-pixmap)))
  (capi:display global-pinboard-test)))