;
; othello program for Schematic 3.1
;
(module schematic-user (with stctk))
(include "schematic.sch")
(define canvas-one #f)
(define my-cursor #f)
(define *-number-of-rows-* 8)
(define *-number-of-cols-* 8)
(define *-size-of-box-* 32)
(define *-dummy-* 777)
(define *-place-* 0)
(define turnwid #f)
(define *-size-of-help-* 256)
(define *-help-margin-* 32)
(define *-turn-* 0)
(define *-marginx-* 32)
(define *-marginy-* 32)
(define *-marble-margin-* 4)
(define *-cursorx-* 0)
(define *-cursory-* 0)
(define scores (make-vector 2 0))
(define scorewid (make-vector 2 #f))
(define *-blank-* 99)
(define boardinfo #f)
(define marbleinfo #f)
(definep (add-scores! pe)
(vector-set! scores pe (+ 1 (vector-ref scores pe))))
(definep (sub-scores! pe)
(vector-set! scores pe (+ (- 1) (vector-ref scores pe))))
(definep (board-init)
(set! boardinfo (make-vector *-number-of-rows-*))
(set! marbleinfo (make-vector *-number-of-rows-*))
(board-init-aux 0) ; fill blank
(board-update! 3 3 0) ; black
(board-update! 4 4 0) ; black
(board-update! 3 4 1) ; white
(board-update! 4 3 1) ; white
(add-scores! 0)
(add-scores! 0)
(add-scores! 1)
(add-scores! 1)
(vector-set! scorewid 0
(update-canvas canvas-one "create" "text" 450 60 :text "foo"))
(vector-set! scorewid 1
(update-canvas canvas-one "create" "text" 450 120 :text "bar"))
(set! turnwid
(update-canvas canvas-one "create" "text" 400 200 :text "Your Turn" :fill (if (= *pe* 0) "red" "blue")))
(if (= *pe* 1)
(update-canvas canvas-one "delete" turnwid))
(score-print)
(put-marble 3 3 *-size-of-box-* 0)
(put-marble 4 4 *-size-of-box-* 0)
(put-marble 4 3 *-size-of-box-* 1)
(put-marble 3 4 *-size-of-box-* 1))
(definep (score-print)
(update-canvas canvas-one "delete" (vector-ref scorewid 0))
(update-canvas canvas-one "delete" (vector-ref scorewid 1))
(vector-set! scorewid 0 (update-canvas canvas-one "create" "text" 450 60 :text (number->string (vector-ref scores 0)) :fill "red"))
(vector-set! scorewid 1 (update-canvas canvas-one "create" "text" 450 120 :text (number->string (vector-ref scores 1)) :fill "blue"))
(if (or (= 64 (+ (vector-ref scores 0) (vector-ref scores 1)))
(= (vector-ref scores 0) 0)
(= (vector-ref scores 1) 0))
(game-over)))
(definep (game-over)
(let ((sc1 (vector-ref scores 0))
(sc2 (vector-ref scores 1)))
(cond
((= sc1 sc2)
(update-canvas canvas-one "create" "text" 400 160 :text "Draw" :fill "DarkGreen"))
((> sc1 sc2)
(if (= *pe* 0)
(update-canvas canvas-one "create" "text" 400 160 :text "You Won!!!" :fill "green")
(update-canvas canvas-one "create" "text" 400 160 :text "You Lost!!!" :fill "green")))
((< sc1 sc2)
(if (= *pe* 0)
(update-canvas canvas-one "create" "text" 400 160 :text "You Lost!!!" :fill "green")
(update-canvas canvas-one "create" "text" 400 160 :text "You Won!!!" :fill "green"))))))
(definep (board-init-aux row)
(if (= row *-number-of-rows-*)
*-dummy-*
(begin
(vector-set! boardinfo row (make-vector *-number-of-cols-* *-blank-*))
(vector-set! marbleinfo row (make-vector *-number-of-cols-* *-blank-*))
(board-init-aux (+ row 1)))))
(definep (matrix-ref mat x y)
(vector-ref (vector-ref mat y) x))
(definep (matrix-set! mat x y v)
(vector-set! (vector-ref mat y) x v))
(definep (Start)
(wm "title" "." "Super Othello")
;;
;; setup button
;;
(bind "." ""
(plambda () (now (change-turn) :on 0)
(now (change-turn) :on 1)))
(bind "." "" "set mousex %x")
(bind "." "" "set mousey %y")
(bind "." ""
(plambda () (begin
; (format #t "B2:~a ~a~%"
; (get-int "mousex")
; (get-int "mousey"))
(if (= *pe* *-turn-*)
(mouse-put-marble (get-int "mousex")
(get-int "mousey")
*pe*)))))
(bind "." "" (plambda () (exit 0)))
;;
;; setup frame for canvas to appear in
;;
(let ((canvas-size-x (+ 1 (* *-marginx-* 2) (* *-number-of-cols-* *-size-of-box-*) *-size-of-help-*))
(canvas-size-y (+ 1 (* *-marginy-* 2) (* *-number-of-rows-* *-size-of-box-*))))
(set! canvas-one (make-canvas ".c" :relief "sunken" :width canvas-size-x :height canvas-size-y))
(pack ".c")
;;
;; Pack evrybody
;;
(make-board)
(board-init)
(update-canvas canvas-one "create" "text" 400 40 :text "Player 1 (Black) Score")
(update-canvas canvas-one "create" "text" 400 100 :text "Player 2 (White) Score")
(write-help)
(update)))
(definep (make-board)
(make-board-aux 0 0)
(make-frame))
(definep (make-board-aux x y)
(if (>= x *-number-of-cols-*)
(if (>= (+ y 1) *-number-of-rows-*)
*-dummy-*
(make-board-aux 0 (+ 1 y)))
(begin
(update-canvas canvas-one "create" "rectangle"
(+ *-marginx-* (* *-size-of-box-* x))
(+ *-marginy-* (* *-size-of-box-* y))
(+ *-marginx-* (* *-size-of-box-* (+ 1 x)) (- 1))
(+ *-marginy-* (* *-size-of-box-* (+ 1 y)) (- 1))
:fill "forestgreen"
:outline "black"
:width 2)
(make-board-aux (+ 1 x) y))))
(definep (make-frame)
(make-frame-1 0 2 "brown")
(make-frame-1 2 2 "SandyBrown")
(make-frame-1 4 2 "black")
(make-frame-1 6 2 "brown")
(make-frame-1 8 2 "SandyBrown")
(make-frame-1 10 2 "black"))
(definep (make-frame-1 delta wid color)
(update-canvas
canvas-one "create" "rectangle"
(- *-marginx-* delta wid)
(- *-marginy-* delta wid)
(+ *-marginx-* (* *-size-of-box-* *-number-of-cols-*) delta (- wid 1))
(+ *-marginy-* (* *-size-of-box-* *-number-of-rows-*) delta (- wid 1))
:outline color
:width wid))
;;; color: 0 --> black, 1 --> white
(definep (put-marble row col delta color)
(matrix-set! marbleinfo col row
(update-canvas canvas-one "create" "oval"
(+ *-marginx-* (* col delta) 1 *-marble-margin-*)
(+ *-marginy-* (* row delta) 1 *-marble-margin-*)
(+ *-marginx-* (* col delta) (- delta 1) (- *-marble-margin-*))
(+ *-marginy-* (* row delta) (- delta 1) (- *-marble-margin-*))
:fill (decode-color color)
:outline "black"
:width 2)))
(definep (write-help)
; (update-canvas canvas-one "create" "text" 400 200 :text "move -----> ")
; (update-canvas canvas-one "create" "text" 450 200 :text "a")
; (update-canvas canvas-one "create" "text" 480 170 :text "w")
; (update-canvas canvas-one "create" "text" 480 230 :text "z")
; (update-canvas canvas-one "create" "text" 510 200 :text "s")
; (update-canvas canvas-one "create" "line" 460 200 500 200 :width 4)
; (update-canvas canvas-one "create" "line" 480 180 480 220 :width 4)
; (update-canvas canvas-one "create" "text" 450 260 :text "put -----> j-key or Button-1")
(update-canvas canvas-one "create" "text" 450 230 :text "put -----> Button-1")
(update-canvas canvas-one "create" "text" 450 260 :text "pass -----> p-key")
(update-canvas canvas-one "create" "text" 450 290 :text "quit -----> o-key"))
(definep (mouse-put-marble mx my blackorwhite)
(let ((x (quotient (- mx *-marginx-*) *-size-of-box-*))
(y (quotient (- my *-marginy-*) *-size-of-box-*)))
(if (and (<= x 7)
(<= 0 x)
(<= y 7)
(<= 0 y)
(eq? (matrix-ref boardinfo x y) *-blank-*))
(let ((dirinfo (reverse-marble x y blackorwhite)))
(if (not (equal? (map car dirinfo) '(0 0 0 0 0 0 0 0)))
(begin
(now (board-update! x y blackorwhite) :on 0)
(now (board-update! x y blackorwhite) :on 1)
(now (add-scores! *pe*) :on 0)
(now (add-scores! *pe*) :on 1)
(now (score-print) :on 0)
(now (score-print) :on 1)
(now (put-marble y x *-size-of-box-* blackorwhite) :on 0)
(now (put-marble y x *-size-of-box-* blackorwhite) :on 1)
(reverse-marble-seq dirinfo x y blackorwhite)
(now (change-turn) :on 0)
(now (change-turn) :on 1))
(display "WARNING --- No Marble Reversed")))
(display "Not Blank Space"))))
(definep (reverse-marble x y selfcolor)
(map (lambda (dirs) (reverse-marble-direction x y (car dirs) (cdr dirs) selfcolor))
'((0 . -1) (1 . -1) (1 . 0) (1 . 1)
(0 . 1) (-1 . 1) (-1 . 0) (-1 . -1))))
(definep (reverse-marble-direction x y dx dy selfcolor)
(cons (number-of-reversed-marble x y dx dy selfcolor) (cons dx dy)))
(definep (reverse-marble-seq dirlist x y selfcolor)
(if (null? dirlist)
*-dummy-*
(let* ((dirinfo (car dirlist))
(num (car dirinfo))
(dx (cadr dirinfo))
(dy (cddr dirinfo)))
(reverse-marble-slowly x y dx dy num selfcolor)
(reverse-marble-seq (cdr dirlist) x y selfcolor))))
(definep (number-of-reversed-marble x y dx dy selfcolor)
(let ((neighborx (+ x dx))
(neighbory (+ y dy)))
(if (or (<= neighborx -1)
(<= *-number-of-cols-* neighborx)
(<= neighbory -1)
(<= *-number-of-rows-* neighbory))
0
(let ((neighborcolor (matrix-ref boardinfo neighborx neighbory)))
(if (eq? neighborcolor (enemy-color selfcolor))
(number-of-reversed-marble-aux neighborx neighbory dx dy selfcolor 1)
0))))) ; can't reverse in this direction
(definep (number-of-reversed-marble-aux x y dx dy selfcolor count)
(let ((neighborx (+ x dx))
(neighbory (+ y dy)))
(if (or (<= neighborx -1)
(<= *-number-of-cols-* neighborx)
(<= neighbory -1)
(<= *-number-of-rows-* neighbory))
0
(let ((neighborcolor (matrix-ref boardinfo neighborx neighbory)))
(cond
((eq? neighborcolor selfcolor) count)
((eq? neighborcolor (enemy-color selfcolor))
(number-of-reversed-marble-aux neighborx neighbory dx dy selfcolor (+ 1 count)))
((eq? neighborcolor *-blank-*) 0))))))
(definep (enemy-color x) (- 1 x))
(definep (decode-color x)
(cond
((eq? x 0) "black")
((eq? x 1) "white")
(else "red")))
(definep (reverse-marble-slowly x y dx dy numofreversed selfcolor)
(if (= 0 numofreversed)
*-dummy-*
(let ((neighborx (+ x dx))
(neighbory (+ y dy)))
(now (reverse-marble-slowly-shrink neighborx neighbory selfcolor 1 1) :on 0)
(now (reverse-marble-slowly-shrink neighborx neighbory selfcolor 1 1) :on 1)
(now (board-update! neighborx neighbory selfcolor) :on 0)
(now (board-update! neighborx neighbory selfcolor) :on 1)
(now (add-scores! *pe*) :on 0)
(now (add-scores! *pe*) :on 1)
(now (sub-scores! (- 1 *pe*)) :on 0)
(now (sub-scores! (- 1 *pe*)) :on 1)
(now (score-print) :on 0)
(now (score-print) :on 1)
(reverse-marble-slowly neighborx neighbory dx dy (- numofreversed 1) selfcolor))))
(definep (reverse-marble-slowly-shrink x y selfcolor reverse-margin delta)
(cond
((<= *-size-of-box-* (* 2 (+ *-marble-margin-* reverse-margin)))
(begin
(update-canvas canvas-one "delete" (matrix-ref marbleinfo x y))
(matrix-set! marbleinfo x y
(update-canvas canvas-one "create" "oval"
(+ *-marginx-* (* x *-size-of-box-*) 1 *-marble-margin-*)
(+ *-marginy-* (* y *-size-of-box-*) 1 *-marble-margin-* reverse-margin)
(+ *-marginx-* (* x *-size-of-box-*) (- *-size-of-box-* 1) (- *-marble-margin-*))
(+ *-marginy-* (* y *-size-of-box-*) (- *-size-of-box-* 1) (- *-marble-margin-*) (- reverse-margin))
:fill (decode-color selfcolor)
:outline "black"
:width 2))
(reverse-marble-slowly-shrink x y selfcolor (- reverse-margin delta) (- delta))))
((<= reverse-margin 0) 'done)
(else
(begin
(canvas-set-coords canvas-one (matrix-ref marbleinfo x y)
(+ *-marginx-* (* x *-size-of-box-*) 1 *-marble-margin-*)
(+ *-marginy-* (* y *-size-of-box-*) 1 *-marble-margin-* reverse-margin)
(+ *-marginx-* (* x *-size-of-box-*) (- *-size-of-box-* 1) (- *-marble-margin-*))
(+ *-marginy-* (* y *-size-of-box-*) (- *-size-of-box-* 1) (- *-marble-margin-*) (- reverse-margin)))
(update)
(pause 15)
(reverse-marble-slowly-shrink x y selfcolor (+ delta reverse-margin) delta)))))
(definep (pause x)
(if (<= x 0)
0
(+ (pause (- x 1)) (pause (- x 2)))))
(definep (change-turn)
(update-canvas canvas-one "delete" turnwid)
(set! *-turn-* (- 1 *-turn-*))
(if (= *pe* *-turn-*)
(set! turnwid
(update-canvas canvas-one "create" "text" 400 200 :text "Your Turn" :fill (if (= *pe* 0) "red" "blue")))))
(definep (board-update! x y color)
(matrix-set! boardinfo x y color))
(definep (schematic-main args)
(now (Start) :on 0)
(now (Start) :on 1)
(format #t "Initialize end~%")
(touch (make-future)))