;
; ten.sc
;

(module schematic-user (with stctk))

(include "schematic.sch")

(define *dir* "/usr/local/src/schematic/demos/tennis/")

(define stop #f)
(define canvas-one (make-vector 1))
(define item "")
(define item0 #f)
(define item1 #f)
(define item2 #f)

(define msg-button #f)

(define bx 50)
(define by 50)
(define bdx 5)
(define bdy 5)

(define i-rx1 200)
(define i-ry1 400)
(define rx1 i-rx1)
(define ry1 i-ry1)
(define i-rx2 200)
(define i-ry2 50)
(define rx2 i-rx2)
(define ry2 i-ry2)

(define rdx_init 10)
(define rdx1 rdx_init)
(define rdx2 rdx_init)
(define rdy1 0)
(define rdy2 0)

(define racket_size_x 80)
(define racket_size_y 5)
(define racket_edgesize_x 10)
(define ball_size_x 10)
(define ball_size_y 10)

(define margin 20)

(define canvas_size_x 500)
(define canvas_size_y 450)

(define x_right_limit (- canvas_size_x margin))
(define x_left_limit  (+ 0 margin))

(define move-one-channel (make-future))

(definep sync-obj #f)

;;; 
;;; Common processes
;;;

(define (future-allpe-iter proc npe)
  (if (= npe 0)
      '()
      (let ((ch (future (proc) :on (- npe 1))))
	(cons ch (future-allpe-iter proc (- npe 1))))))

(define (future-allpe proc) (future-allpe-iter proc *npe*))

(define (touch-all chlist)
  (if (null? chlist)
      '()
      (cons (touch (car chlist)) (touch-all (cdr chlist)))))

(define (do-allpe proc) (touch-all (future-allpe proc)))

;;;
;;;
;;;

(definep (init-var)
  (set! bx 50)
  (set! by 50)
  (set! bdx 5)
  (set! bdy 5)
  (set! rx1 i-rx1)
  (set! ry1 i-ry1)
  (set! rx2 i-rx2)
  (set! ry2 i-ry2)
  (set! rdx1 rdx_init)
  (set! rdx2 rdx_init))

(definep (set-stop v) (set! stop v))
(definep (set-sync o) (set! sync-obj o))

(definep (Start)
  (wm "title" "." "Table Tennis")
  ;;
  ;; setup button
  ;;
  (frame ".f")
  (if (= *pe* 0)
      (begin
	(make-button ".f.run"  :text "Run"
		     :command
		     game-start)
	
	(make-button ".f.stop" :text "Stop"
		     :command
		     (plambda ()
			      (now (set-stop #t))
			      (now (set-stop #t) :on 1)))
	(make-button ".f.quit" :text "Quit" :command (plambda () (exit 0)))
	(pack ".f.run" ".f.stop" ".f.quit" :fill "x" :side "left" :expand #t))
      (begin
	(make-button ".f.dummy" :text ""
		     :command (plambda () 0))
	(pack ".f.dummy" :fill "x" :side "left" :expand #t)))
  
  (bind "." "" (plambda () (exit 0)))
  (bind "." ""
	(plambda () (set-dx (- rdx_init))))
  (bind "." ""
	(plambda () (set-dx 0)))
  (bind "." ""
	(plambda () (set-dx rdx_init)))

  (frame ".l" :bd 4)
  (set! msg-button (make-button ".l.l" :text "Table Tennis"))
  (pack ".l.l" :fill "x")

  ;;
  ;; setup frame for canvas to appear in
  ;;
  (frame ".canv-frame" :bd 4 :relief "groove")
  (set! canvas-one (make-canvas ".canv-frame.canvas"
				"-background" "green"
				:relief "sunken"))
  (pack ".canv-frame.canvas")
  (update-canvas canvas-one "configure" :width canvas_size_x :height canvas_size_y)

  (update-canvas canvas-one "create"
		 "line" 30 30 30 (- canvas_size_y 30)
		 :fill "white" :width 3)
  (update-canvas canvas-one "create"
		 "line" 30 (- canvas_size_y 30) 
		 (- canvas_size_x 30) (- canvas_size_y 30)
		 :fill "white" :width 3)
  (update-canvas canvas-one "create"
		 "line" (- canvas_size_x 30) (- canvas_size_y 30) 
		 (- canvas_size_x 30) 30
		 :fill "white" :width 3)
  (update-canvas canvas-one "create"
		 "line" (- canvas_size_x 30) 30 30 30
		 (- canvas_size_x 30) 30
		 :fill "white" :width 3)
  (update-canvas canvas-one "create"
		 "line" 30 (/ canvas_size_y 2)
		 (- canvas_size_x 30) (/ canvas_size_y 2)
		 :fill "white" :width 3)

  ;;
  ;; Pack evrybody
  ;;
  (pack ".canv-frame" ".l" ".f" :expand #t :fill "x")

  (set! item0 (update-canvas canvas-one "create"
			 "oval" bx by (+ bx ball_size_x) (+ by ball_size_y)
			 :fill "white"
			 :outline "red"
			 :width 2))

  (set! item1 (update-canvas canvas-one"create"
			 "rectangle" rx1 ry1 (+ rx1 racket_size_x) (+ ry1 racket_size_y)
			 :fill "blue"
			 :outline "black"
			 :width 2))
  (set! item2 (update-canvas canvas-one "create"
			 "rectangle" rx2 ry2 (+ rx2 racket_size_x) (+ ry2 racket_size_y)
			 :fill "yellow"
			 :outline "black"
			 :width 2))
)

(definep (Move-Ball-s)
  (Move-Ball canvas-one item0   "red"))

(definep (Move-Ball can i color)
  (if (eq? stop #f)
      (begin
	(if (> (+ bx ball_size_x) x_right_limit)
	    (if (> bdx 0)
		(set! bdx (- bdx))))
	(if (< bx x_left_limit)
	    (if (< bdx 0)
		(set! bdx (- bdx))))
	(if (and (> bdy 0) (> (+ by ball_size_y bdy) ry1))
	    (collision1))
	(if (and (< bdy 0) (< by (+ ry2 racket_size_y)))
	    (collision2))
	(if (< by 10)
	    (set! bdy (- bdy)))
	(set! bx  (+ bx bdx))
	(set! by  (+ by bdy))
	(let ((r (future (Draw-Ball-remote bx by bdx bdy) :on 1)))
	  (canvas-set-coords can i bx by (+ bx ball_size_x) (+ by ball_size_y))
	  ;	(yield color)
	  (future (update))
	  (touch r))
	(wait! sync-obj)
	(Move-Ball can i color))))

(definep (Draw-Ball-remote x y dx dy) (:reply-to r)
  (let ((can canvas-one)
	(i item0)
	(color "red"))
    (set! bx x)
    (set! by y)
    (set! bdx dx)
    (set! bdy dy)
    (reply 0 r)
    (if (eq? stop #f)
	(begin
	  (canvas-set-coords can i bx by (+ bx ball_size_x) (+ by ball_size_y))
	  ;	(yield color)
	  (future (update))))))

(definep (Move-Racket1-s)
  (Move-Racket1 canvas-one item1  "blue"))

(definep (Move-Racket1 can i color)
  (if (eq? stop #f)
      (begin
	(set! rx1 (+ rx1 rdx1))
	(if (> (+ rx1 racket_size_x) x_right_limit)
	    (set! rx1 (- x_right_limit racket_size_x)))
	(if (< rx1 x_left_limit)
	    (set! rx1 x_left_limit))
	(let ((r (future (Draw-Racket1-remote rx1 ry1 rdx1 rdy1) :on 1)))
	  (canvas-set-coords can i rx1 ry1 (+ rx1 racket_size_x) (+ ry1 racket_size_y))
	  ;    (yield color)
	  (future (update))
	  (touch r))
	(wait! sync-obj)
	(Move-Racket1 can i color))))

(definep (Draw-Racket1-remote x y dx dy) (:reply-to r)
  (let ((can canvas-one)
	(i item1)
	(color "blue"))
    (set! rx1 x)
    (set! ry1 y)
    (set! rdx1 dx)
    (set! rdy1 dy)
    (reply 0 r)
    (if (eq? stop #f)
	(begin
	  (canvas-set-coords can i rx1 ry1 (+ rx1 racket_size_x) (+ ry1 racket_size_y))
	  ;    (yield color)
	  (future (update))))))

(definep (Move-Racket2-s)
  (Move-Racket2 canvas-one item2 "yellow"))

(definep (Move-Racket2 can i color)
  (if (eq? stop #f)
      (begin
	(set! rx2 (+ rx2 rdx2))
	(if (> (+ rx2 racket_size_x) x_right_limit)
	    (set! rx2 (- x_right_limit racket_size_x)))
	(if (< rx2 x_left_limit)
	    (set! rx2 x_left_limit))
	(let ((r (future (Draw-Racket2-remote rx2 ry2 rdx2 rdy2) :on 0)))
	  (canvas-set-coords can i rx2 ry2 (+ rx2 racket_size_x) (+ ry2 racket_size_y))
	  ;    (yield color)
	  (future (update))
	  (touch r))
	(wait! sync-obj)
	(Move-Racket2 can i color))))

(definep (Draw-Racket2-remote x y dx dy) (:reply-to r)
  (let ((can canvas-one)
	(i item2)
	(color "yellow"))
    (set! rx2 x)
    (set! ry2 y)
    (set! rdx2 dx)
    (set! rdy2 dy)
    (reply 0 r)
    (if (eq? stop #f)
	(begin
	  (canvas-set-coords can i rx2 ry2 (+ rx2 racket_size_x) (+ ry2 racket_size_y))
	  ;    (yield color)
	  (future (update))))))

(define (collision1)
  (if (and (< rx1 (+ bx ball_size_x))
	   (< bx (+ rx1 racket_size_x)))
      (begin
	(collect)
	(if (< bx (+ rx1 racket_edgesize_x))
	    (begin
	      (set! bdy (if (>= bdx 0) 
			    (* bdy -1.4)
			    (* bdy -0.8)))
	      (set! bdx (+ bdx -10 (/ rdx2 3))))
	    (if (> bx (+ rx1 (- racket_size_x racket_edgesize_x)))
		(begin
		  (set! bdy (if (<= bdx 0) 
				(* bdy -1.4)
				(* bdy -0.8)))
		  (set! bdx (+ bdx 10 (/ rdx2 3))))
		(begin
		  (set! bdy (- bdy))
		  (set! bdx (+ bdx (/ rdx1 3)))))))
      (if (> by (+ ry1 racket_size_y))
	  (game-over "yellow"))))

(define (collision2)
  (if (and (< rx2 (+ bx ball_size_x))
	   (< bx (+ rx2 racket_size_x)))
      (begin
	(collect)
	(if (< bx (+ rx2 racket_edgesize_x))
	    (begin
	      (set! bdy (if (>= bdx 0) 
			    (* bdy -1.4)
			    (* bdy -0.8)))
	      (set! bdx (+ bdx -10 (/ rdx2 3))))
	    (if (> bx (+ rx2 (- racket_size_x racket_edgesize_x)))
		(begin
		  (set! bdy (if (<= bdx 0) 
				(* bdy -1.4)
				(* bdy -0.8)))
		  (set! bdx (+ bdx 10 (/ rdx2 3))))
		(begin
		  (set! bdy (- bdy))
		  (set! bdx (+ bdx (/ rdx2 3)))))))
      (if (< (+ by ball_size_y) ry2)
	  (game-over "blue"))))

;;;
;;;
;;;

(definep (set-dx d)
  (if (= *pe* 0)
      (set! rdx1 d)
      (set! rdx2 d)))

(definep (write-msg msg)
  (update-button msg-button "configure" :text msg))

(definep (game-start)
  (now (set-stop #f))
  (now (set-stop #f) :on 1)
  (collect-all)
  (clear! sync-obj)
  (future (Move-Ball-s))
  (future (Move-Racket1-s))
  (future (Move-Racket2-s) :on 1)
  (do-allpe (plambda () (write-msg "[j] <- [k] -> [l]"))))

(definep (game-over winner)
  (now (set-stop #t) :on 0)
  (now (set-stop #t) :on 1)
  (do-allpe (plambda ()
		     (write-msg (string-append "Player "
					       winner
					       " wins!!"))))
  (now (init-var) :on 0)
  (now (init-var) :on 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-generic (wait! self))
(define-generic (clear! self))

(define-class synchronizer ()
  n count waiters)

(define-method! synchronizer (wait! self)
  (:reply-to r)
  (if (= (+ count 1) n)
      (become (for-each (plambda (x) (reply #t x)) (cons r waiters))
	      :n n :count 0 :waiters '())
      (become #t
	      :n n :count (+ count 1) :waiters (cons r waiters))))

(define-method! synchronizer (clear! self)
  (become #t :n n :count 0 :waiters '()))

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

(definep (schematic-main args)
;  (tk-init "+100+100")
;  (let ((r (future (tk-init "+100+100") :on 1)))
;    (touch r))
  (let ((o (synchronizer 3 0 '())))
    (now (set-sync o) :on 0)
    (now (set-sync o) :on 1))
  (now (Start) :on 0)
  (now (Start) :on 1)
  (format #t "Initialize end~%")
  (touch (make-future))
)