;
; hyper.sc
;

(module schematic-user (with stctk))

(include "schematic.sch")

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

(define *stop* #t)
(define *score* (make-vector *npe*))
(define *round* 0)
(define *n-round* 3)
(define *in-game* #f)
(define canvas-one (make-vector 1))

(define item-r0 (vector #f))
(define item-r1 (vector #f))

(define msg-button #f)

(define rx 0)
(define ry 0)
(define key-idx 0)
(define img-idx 0)

(define *trr-string* "jkl")
(define *trr-strings* #f)
(define *seed-string* "abcdefghijklmnopqrstuvwxyz")
(define *player-name* '#("A" "B"))

(define i-rx0 50)
(define i-ry0 50)
(define i-rx1 50)
(define i-ry1 150)

(define goal-x 550)

(define racket_size_x 64)
(define racket_size_y 64)

(define margin 20)

(define canvas_size_x 600)
(define canvas_size_y 200)

(define sync-obj #f)

(define ST-NOGAME 1)
(define ST-RUNNING 2)
(define ST-GOAL 3)

;;; 
;;; 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! key-idx 0)
  (set! img-idx 0)
  (if (= *pe* 0)
      (begin
	(set! rx i-rx0)
	(set! ry i-ry0))
      (begin
	(set! rx i-rx1)
	(set! ry i-ry1))))

(definep (set-stop v) (set! *stop* v))
(definep (set-sync o) (set! sync-obj o))
(definep (set-round r) (set! *round* r))
(definep (set-trr s) (set! *trr-string* s))

(definep (Start)
  (wm "title" "." "Hyper Athletic")
  ;;
  ;; setup button
  ;;
  (frame ".f")
  (if (= *pe* 0)
      (begin
	(make-button ".f.run"  :text "Start Game"
		     :command
		     (plambda () (if (eq? *in-game* #f) (game-start-all))))
	
;	(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.quit" :fill "x" :side "left" :expand #t))
      (begin
	(make-button ".f.dummy" :text "Dummy"
		     :command (plambda () 0))
	(pack ".f.dummy" :fill "x" :side "left" :expand #t)))
  
  ;; bind all keys!
  (bind "." ""	(plambda () (key-in #\-)))
  (bind "." ""	(plambda () (key-in #\()))
  (bind "." ""	(plambda () (key-in #\))))
  
  (let loop ((i 0))
    (if (>= i (string-length *seed-string*))
	#t
	(begin
	  (let ((ch (string-ref *seed-string* i)))
	    (let ((com (string-append "")))
	      (bind "." com
		    (plambda () (key-in ch)))))
	  (loop (+ i 1)))))
  
  ;;
  ;;
  ;;
  
  (frame ".l" :bd 4)
  (set! msg-button (make-button ".l.l" :text ""))
  (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" :relief "sunken"))
  (pack ".canv-frame.canvas")
  (update-canvas canvas-one "configure" :width canvas_size_x :height canvas_size_y)
  
  (image "create" "photo" "im0" :file (string-append *dir* "tr.gif"))

  (update-canvas canvas-one "create" "image" 300 100 :image "im0")

  (image "create" "photo" "im-r0a" :file (string-append *dir* "man1.gif"))
  (image "create" "photo" "im-r0b" :file (string-append *dir* "man2.gif"))
  (image "create" "photo" "im-r1a" :file (string-append *dir* "man1.gif"))
  (image "create" "photo" "im-r1b" :file (string-append *dir* "man2.gif"))

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

  (init-var)
  (read-trr-strings)
  (vector-set! item-r0 0
	       (update-canvas canvas-one "create"
			      "image" i-rx0 i-ry0
			      :image "im-r0a"))
  (vector-set! item-r1 0
	       (update-canvas canvas-one "create"
			      "image" i-rx1 i-ry1
			      :image "im-r1a"))
  )

;;;
;;;
;;;

(definep (mainloop)
  (if (eq? *stop* #f)
      (begin
	(update)
	(let ((goaled (wait! sync-obj *pe* 
			     (if (>= rx goal-x) ST-GOAL ST-RUNNING))))
	  (if (pair? goaled)
	      (if (= *pe* 0)
		  (game-over goaled))
	      (mainloop))))))

(definep (key-in k)
  (if (and (eq? *stop* #f) (eqv? k (string-ref *trr-string* key-idx)))
      (begin
	(set! key-idx
	      (if (>= (+ key-idx 1) (string-length *trr-string*))
		  0
		  (+ key-idx 1)))
	(set! img-idx (- 1 img-idx))
	(set! rx (+ rx 10))
	(let ((id *pe*))
	  (let ((r (future (Draw-Racket rx ry id img-idx) :on (- 1 *pe*))))
	    (Draw-Racket rx ry id img-idx)
	    (touch r))))))

(definep (Draw-Racket x y id mode)
  (let ((can canvas-one)
	(i (if (= id 0) item-r0 item-r1))
	(im (if (= id 0)
		(if (= mode 0) "im-r0a" "im-r0b")
		(if (= mode 0) "im-r1a" "im-r1b"))))
    (update-canvas can "delete" (vector-ref i 0))
    (vector-set! i 0
		 (update-canvas canvas-one "create"
				"image" x y
				:image im))
    (update)))

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

(definep (read-trr-strings)
  (let ((f (open-input-file (string-append *dir* "strings.dat"))))
    (set! *trr-strings* (read f))
    (close-input-port f)))

(definep (countdown)
  (begin
    (init-var)
    (let ((id *pe*))
      (let ((r (future (Draw-Racket rx ry id img-idx) :on (- 1 *pe*))))
	(Draw-Racket rx ry id img-idx)
	(touch r)))
    (wait! sync-obj *pe* ST-NOGAME)
    (let ((i0 (update-canvas canvas-one "create"
			     "rectangle" 90 10 150 150
			     :fill "black"))
	  (i1 0) (i2 0) (i3 0))
      (write-msg (string-append "Round " (number->string *round*)))
      (update)
      (collect-all)
      (set! i1 (update-canvas canvas-one "create"
			      "oval" 100 20 140 60
			      :width 2 :fill "red"))
      (update)
      (system "sleep 1")
      (wait! sync-obj *pe* ST-NOGAME)
      (set! i2 (update-canvas canvas-one "create"
			      "oval" 100 60 140 100
			      :width 2 :fill "red"))
      (write-msg (string-append "Press [" *trr-string* "]"))
      (update)
      (system "sleep 1")
      (wait! sync-obj *pe* ST-NOGAME)
      (set! i3 (update-canvas canvas-one "create"
			      "oval" 100 100 140 140
			      :width 2 :fill "green"))
      (write-msg "FIGHT !")
      (update)
      (system "sleep 1")
      (update-canvas canvas-one "delete" i0)
      (update-canvas canvas-one "delete" i1)
      (update-canvas canvas-one "delete" i2)
      (update-canvas canvas-one "delete" i3)
      (write-msg (string-append "Press [" *trr-string* "]"))
      (wait! sync-obj *pe* ST-NOGAME)
      (update)
      (set-stop #f))))

;;; called in only PE 0
(definep (game-start)
  (let ((s (select-random-string)))
    (do-allpe (plambda () (set-trr s))))
  (clear! sync-obj)
  (do-allpe countdown)
  (future (mainloop) :on 0)
  (future (mainloop) :on 1))

(definep (game-start-all)
  (set! *in-game* #t)
  (init-random (current-time))
  (set! *score* (make-vector *npe* 0))
  (do-allpe (plambda () (set-round 1)))
  (game-start))

(definep (add-score n s)
  (vector-set! *score* n (+ (vector-ref *score* n) s)))

(definep (game-over winner)
  (do-allpe (plambda () (set-stop #t)))
  (let ((msg ""))
    (if (= (length winner) 1)
	(begin
	  (add-score (car winner) 2)
	  (set! msg (string-append "Player "
				   (vector-ref *player-name* (car winner))
				   " Wins!!")))
	(begin
	  (for-each (plambda (n) (add-score n 1)) winner)
	  (set! msg "Draw")))
    (do-allpe (plambda () (write-msg msg) (update))))
  (if (< *round* *n-round*)
      (begin (let ((r (+ *round* 1)))
	       (do-allpe (plambda () (set-round r))))
	     (system "sleep 2")
	     (game-start))
      (begin
	(system "sleep 2")
	(game-over-all))))

(definep (judge-total-winner)
  (let loop ((i 0) (mmm -1) (winner '()))
    (if (= i *npe*)
	winner
	(let ((s (vector-ref *score* i)))
	  (if (> s mmm)
	      (loop (+ i 1) s (cons i '()))
	      (if (= s mmm)
		  (loop (+ i 1) mmm (cons i winner))
		  (loop (+ i 1) mmm winner)))))))

(definep (game-over-all)
  (let ((winner (judge-total-winner))
	(msg ""))
    (if (= (length winner) 1)
	(begin
	  (set! msg (string-append "Totally Player "
				   (vector-ref *player-name* (car winner))
				   " Wins!!")))
	(begin
	  (set! msg "Totally Draw")))
    (do-allpe (plambda () (write-msg msg) (update))))
  (system "sleep 2")
  (set! *in-game* #f))

(definep (judge-goal v)
  (let loop ((i 0))
    (if (= i *npe*)
	'()
	(begin ;(format #t "ref-idx ~s~%" i)
	       (if (eqv? (vector-ref v i) ST-GOAL)
		   (cons i (loop (+ i 1)))
		   (loop (+ i 1)))))))

(definep (select-random-string)
  (let ((v (vector-ref *trr-strings* (- *round* 1))))
    (vector-ref v (remainder (random) (vector-length v)))))

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

(define-class synchronizer ()
  n count waiters status-v)

(define-method! synchronizer (wait! self id st)
  (:reply-to r)
  (if (= (+ count 1) n)
      (begin
	(vector-set! status-v id st)
	(let ((ans (judge-goal status-v)))
	  (become (for-each (plambda (x) (reply ans x)) (cons r waiters))
		  :n n :count 0 :waiters '() :status-v status-v)))
      (begin
	(vector-set! status-v id st)
	(become #t
		:n n :count (+ count 1) :waiters (cons r waiters)
		:status-v status-v))))

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

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

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