From 4f13b3f1d538e9390fe9a13dcce31c1f78e0d687 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 12 Feb 2013 04:49:12 -0500 Subject: [PATCH] More code therapy. --- collects/games/jewel/array.rkt | 226 +-- collects/games/jewel/jewel.rkt | 3010 +++++++++++++------------------ collects/games/jewel/shapes.rkt | 946 +++++----- collects/games/jewel/text.rkt | 366 ++-- 4 files changed, 1945 insertions(+), 2603 deletions(-) diff --git a/collects/games/jewel/array.rkt b/collects/games/jewel/array.rkt index dd6a956f2d..ae801ca12a 100644 --- a/collects/games/jewel/array.rkt +++ b/collects/games/jewel/array.rkt @@ -1,169 +1,99 @@ -; -*- Scheme -*- +;; -*- Scheme -*- -(module array racket +#lang racket (provide array-make array-ref array-set! array-mult array-mult-vector - array-det array-sub array-inv -) + array-det array-sub array-inv) - -; creates a square matrix, nxn +;; creates a square matrix, nxn (define (array-make n) - (let* - ( (a (make-vector n #f)) ) - (do ((i 0 (+ i 1))) ((= i n)) - (vector-set! a i (make-vector n 0.0)) - ) - a - ) -) + (define a (make-vector n #f)) + (for ([i (in-range n)]) + (vector-set! a i (make-vector n 0.0))) + a) -; returns an array element +;; returns an array element (define (array-ref m i j) - (vector-ref (vector-ref m i) j) -) + (vector-ref (vector-ref m i) j)) -; sets an array element +;; sets an array element (define (array-set! m i j val) - (let* - ( (vect (vector-ref m i)) ) - (vector-set! vect j val) - ) -) + (vector-set! (vector-ref m i) j val)) -; matrix - matrix multiplication +;; matrix - matrix multiplication (define (array-mult a b) - (let* - ( (n (vector-length a)) - (m (array-make n)) - ) - (do ((i 0 (+ i 1))) ((= i n)) - (do ((j 0 (+ j 1))) ((= j n)) - (do ((k 0 (+ k 1))) ((= k n)) - (array-set! m i j (+ (array-ref m i j) - (* (array-ref a i k) - (array-ref b k j)))) - ) - ) - ) - m - ) -) + (define n (vector-length a)) + (define m (array-make n)) + (for* ([i (in-range n)] + [j (in-range n)] + [k (in-range n)]) + (array-set! m i j (+ (array-ref m i j) + (* (array-ref a i k) + (array-ref b k j))))) + m) -; vector - matrix multiplication +;; vector - matrix multiplication (define (array-mult-vector m v) - (let* ( (r (make-vector 4 0)) ) - (do ((i 0 (+ 1 i))) ((= i 4)) - (do ((j 0 (+ 1 j))) ((= j 4)) - (vector-set! r - i - (+ (* (array-ref m i j) (vector-ref v j)) - (vector-ref r i))) - ) - ) - r - ) -) + (define r (make-vector 4 0)) + (for* ([i (in-range 4)] + [j (in-range 4)]) + (vector-set! r i (+ (* (array-ref m i j) (vector-ref v j)) + (vector-ref r i)))) + r) -; calculates the determinant of a matrix +;; calculates the determinant of a matrix (define (array-det a) - (cond - ( (= (vector-length a) 1) - (array-ref a 0 0) - ) - ( (= (vector-length a) 2) - (- (* (array-ref a 0 0) (array-ref a 1 1)) - (* (array-ref a 1 0) (array-ref a 0 1)) ) - ) - ( else - (let* - ( (n (vector-length a)) - (det 0.0) - (m #f) - (j2 #f) - ) - (do ((j1 0 (+ j1 1))) ((= j1 n)) - ; create sub-matrix - (set! m (array-make (- n 1))) - (do ((i 1 (+ i 1))) ((= i n)) - (set! j2 0) - (do ((j 0 (+ j 1))) ((= j n)) - (when (not (= j j1)) - (begin - (array-set! m (- i 1) j2 (array-ref a i j)) - (set! j2 (+ j2 1)) - ) - ) - ) - ) - (set! det (+ det (* (expt -1 (+ 1 j1 1)) - (array-ref a 0 j1) - (array-det m) - ) - ) - ) - ) - ; return the determinant - det - ) - ) - ) -) + (cond [(= (vector-length a) 1) + (array-ref a 0 0)] + [(= (vector-length a) 2) + (- (* (array-ref a 0 0) (array-ref a 1 1)) + (* (array-ref a 1 0) (array-ref a 0 1)))] + [else + (define n (vector-length a)) + (define det 0.0) + (define m #f) + (define j2 #f) + (for ([j1 (in-range n)]) + ;; create sub-matrix + (set! m (array-make (- n 1))) + (for ([i (in-range 1 n)]) + (set! j2 0) + (for ([j (in-range n)] #:unless (= j j1)) + (array-set! m (- i 1) j2 (array-ref a i j)) + (set! j2 (+ j2 1)))) + (set! det (+ det (* (expt -1 (+ 1 j1 1)) + (array-ref a 0 j1) + (array-det m))))) + ;; return the determinant + det])) -; creates a sub-matrix, except row 'in' and column 'jn' +;; creates a sub-matrix, except row 'in' and column 'jn' (define (array-sub a in jn) - (let* - ( (n (vector-length a)) - (m (array-make (- n 1))) - (ii 0) - (jj 0) - ) - (do ((i 0 (+ i 1))) ((= i n)) - (when (not (= i in)) - (begin - (set! jj 0) - (do ((j 0 (+ j 1))) ((= j n)) - (when (not (= j jn)) - (begin - (array-set! m ii jj (array-ref a i j)) - (set! jj (+ jj 1)) - ) - ) - ) - (set! ii (+ ii 1)) - ) - ) - ) - m - ) -) + (define n (vector-length a)) + (define m (array-make (- n 1))) + (define ii 0) + (define jj 0) + (for ([i (in-range n)] #:unless (= i in)) + (set! jj 0) + (for ([j (in-range n)] #:unless (= j jn)) + (array-set! m ii jj (array-ref a i j)) + (set! jj (+ jj 1))) + (set! ii (+ ii 1))) + m) -; calculates the inverse of a matrix +;; calculates the inverse of a matrix (define (array-inv a) - (let* - ( (n (vector-length a)) - (m (array-make n)) - (det (array-det a)) - ) - (do ((i 0 (+ i 1))) ((= i n)) - (do ((j 0 (+ j 1))) ((= j n)) - (array-set! m j i (/ (* (expt -1 (+ i j)) - (array-det (array-sub a i j)) - ) - det)) - ) - ) - m - ) -) - - - -; (define aa '#( #( 1 2 3) #( 4 4 0) #( 0 0 10) ) ) -; (define bb (array-inv aa)) -; (array-mult aa bb) - -) ; end of module - + (define n (vector-length a)) + (define m (array-make n)) + (define det (array-det a)) + (for* ([i (in-range n)] + [j (in-range n)]) + (array-set! m j i (/ (* (expt -1 (+ i j)) + (array-det (array-sub a i j))) + det))) + m) +;; (define aa '#(#(1 2 3) #(4 4 0) #(0 0 10))) +;; (define bb (array-inv aa)) +;; (array-mult aa bb) diff --git a/collects/games/jewel/jewel.rkt b/collects/games/jewel/jewel.rkt index d8de976193..8b22fbd931 100644 --- a/collects/games/jewel/jewel.rkt +++ b/collects/games/jewel/jewel.rkt @@ -1,1828 +1,1374 @@ -; FIXME: -; - object rotation axis could be random per type +;; FIXME: +;; - object rotation axis could be random per type -(module jewel racket +#lang racket - (require racket/unit - racket/class - racket/file - racket/gui - sgl/gl - sgl/gl-vectors - (only-in sgl/sgl get-gl-version-number) - "shapes.rkt" - "array.rkt" - "text.rkt" - "../show-scribbling.rkt" - ) +(require racket/unit + racket/class + racket/file + racket/gui + sgl/gl + sgl/gl-vectors + (only-in sgl/sgl get-gl-version-number) + "shapes.rkt" + "array.rkt" + "text.rkt" + "../show-scribbling.rkt") - (provide game@) +(provide game@) +(define game@ (unit (import) (export) - (define game@ - (unit - (import) - (export) +;; ----------------------------------------------------------------- +;; global constants +;; ----------------------------------------------------------------- - ; ----------------------------------------------------------------- - ; global constants - ; ----------------------------------------------------------------- - - ; defines whether animation is frozen - (define freeze #f) - ; animation frame time interval - (define timer-interval 30) +;; defines whether animation is frozen +(define freeze #f) +;; animation frame time interval +(define timer-interval 30) - ; number of points achieved in the game - (define jewel-score #f) - ; game level - (define jewel-level #f) - ; number of available moves - (define jewel-nmoves #f) - ; stage in the game - (define jewel-stage #f) - ; how quickly life is decreased - (define jewel-decay #f) - ; life points - (define jewel-life #f) - ; difficulty level - (define jewel-difficulty 0) +;; number of points achieved in the game +(define jewel-score #f) +;; game level +(define jewel-level #f) +;; number of available moves +(define jewel-nmoves #f) +;; stage in the game +(define jewel-stage #f) +;; how quickly life is decreased +(define jewel-decay #f) +;; life points +(define jewel-life #f) +;; difficulty level +(define jewel-difficulty 0) - ; table of high scores, loaded from a file - (define high-scores (vector - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - '("NOBODY" "0" "1") - )) - - (define startlife 1000.0) - (define lifevisible (* startlife 2.0)) - (define credit 10.0) - (define initialdecay 0.4) - (define decayadd 0.02) - (define nextlevel 10) - (define dist 20) - - ; Values can be: - ; PLAYING, GAME-OVER, DIFFICULTY - (define gamestate #f) - ; Values can be: - ; ACTION-LOOKING, ACTION-WAITING, - ; ACTION-REMOVING, ACTION-DROPPING - ; ACTION-SWAPPING, ACTION-UNSWAPPING - (define action-mode #f) - ; mouse over this element - (define cposx 0) - (define cposy 0) - ; rate of vanishing and rate of falling - (define vanishrate 0.05) - (define fallrate 0.05) - ; swapping is done in how many steps - (define swaptime 20) - ; when mouse button is pressed, this stores the position - (define down-x #f) - (define down-y #f) - ; tells whether the mouse button is pressed - (define isdown? #f) - ; has something been selected for swapping - (define tryswap? #f) - (define font-scale 0.09) - ; for keyboard-based game: - (define bubble-x #f) - (define bubble-y #f) - (define revert-bubble-x #f) - (define revert-bubble-y #f) - (define locked? #f) +;; table of high scores, loaded from a file +(define high-scores (vector '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1") + '("NOBODY" "0" "1"))) - (define need-help? #t) - - (define white #(1.0 1.0 1.0 1.0)) - (define white2 #(0.7 0.7 0.7 1.0)) - (define grey #(0.75 0.75 0.75 1.0)) - (define grey2 #(0.75 0.75 0.75 1.0)) - (define bubble-color #(0.8 0.6 1.0 0.4)) - (define bubble-lock-color #(1.0 1.0 1.0 0.4)) - (define spacing 1.76) - (define shiftx 3.0) - (define shifty 0.0) - (define scorex -8.0) - (define scorey 5.5) - (define scorez 8.0) - (define linespace 2.5) - (define ex 8) - (define ey 8) - (define objectlists #f) - (define lightpos #(-2.0 4.0 4.0 0.0)) - (define light1pos #(22.0 2.0 4.0 0.0)) - (define light2pos #(0.0 0.0 4.0 0.0)) - (define diff-color 0) - (define diff-shape 0) +(define startlife 1000.0) +(define lifevisible (* startlife 2.0)) +(define credit 10.0) +(define initialdecay 0.4) +(define decayadd 0.02) +(define nextlevel 10) +(define dist 20) - (define color-map #( #(0.2 0.2 1.0 1.0) ; blue - #(1.0 0.5 0.0 1.0) ; orange - #(1.0 1.0 0.0 1.0) ; yellow - #(1.0 0.0 1.0 1.0) ; magenta - #(0.0 0.8 0.2 1.0) ; green - #(0.8 0.1 0.0 1.0) ; red - #(1.0 1.0 1.0 1.0) ; white - )) - - ; 4 x 4 matrices - (define unproject_matrix - '#( #(0.266667 0.0 0.0 0.0) - #(0.0 0.2 0.0 0.0) - #(0.0 0.0 -26.881655 30.769228) - #(0.0 0.0 -0.846154 1.0) ) - ) - ; 4 element vector - (define viewport #f) - - - ; ----------------------------------------------------------------- - ; Defining window toolkit classes - ; ----------------------------------------------------------------- - - ; defines a new main window - (define jewel-frame% - (class* frame% () - - (define/augment (on-close) - (jewel-quit-game) - ) - - (define/override (on-subwindow-char window event) - (let* - ( (c (send event get-key-code)) - (needed-help? need-help?)) - (set! need-help? #f) - (cond - ; ESCAPE character exits - ( (eq? c 'escape) - (if (not (equal? gamestate 'GAME-OVER)) - (begin - (set! freeze #f) - (send *TIMER* start timer-interval) - (set! gamestate 'GAME-OVER) - ) - (begin - (jewel-quit-game) - (send *MAIN_WINDOW* show #f) - ) - ) - ) - ( (eq? c #\space) - (if (equal? gamestate 'GAME-OVER) - (begin - (difficulty-ask) - ) - (jewel-key-lock) - ) - ) - ( (or (eq? c #\h) (eq? c #\H)) - (show-jewel-help) ) - ( (or (eq? c #\p) (eq? c #\P)) - (when (equal? gamestate 'PLAYING) - (begin - (set! freeze (not freeze)) - (if freeze - (send *TIMER* stop) +;; Values can be: +;; PLAYING, GAME-OVER, DIFFICULTY +(define gamestate #f) +;; Values can be: +;; ACTION-LOOKING, ACTION-WAITING, +;; ACTION-REMOVING, ACTION-DROPPING +;; ACTION-SWAPPING, ACTION-UNSWAPPING +(define action-mode #f) +;; mouse over this element +(define cposx 0) +(define cposy 0) +;; rate of vanishing and rate of falling +(define vanishrate 0.05) +(define fallrate 0.05) +;; swapping is done in how many steps +(define swaptime 20) +;; when mouse button is pressed, this stores the position +(define down-x #f) +(define down-y #f) +;; tells whether the mouse button is pressed +(define isdown? #f) +;; has something been selected for swapping +(define tryswap? #f) +(define font-scale 0.09) +;; for keyboard-based game: +(define bubble-x #f) +(define bubble-y #f) +(define revert-bubble-x #f) +(define revert-bubble-y #f) +(define locked? #f) + +(define need-help? #t) + +(define white #(1.0 1.0 1.0 1.0)) +(define white2 #(0.7 0.7 0.7 1.0)) +(define grey #(0.75 0.75 0.75 1.0)) +(define grey2 #(0.75 0.75 0.75 1.0)) +(define bubble-color #(0.8 0.6 1.0 0.4)) +(define bubble-lock-color #(1.0 1.0 1.0 0.4)) +(define spacing 1.76) +(define shiftx 3.0) +(define shifty 0.0) +(define scorex -8.0) +(define scorey 5.5) +(define scorez 8.0) +(define linespace 2.5) +(define ex 8) +(define ey 8) +(define objectlists #f) +(define lightpos #(-2.0 4.0 4.0 0.0)) +(define light1pos #(22.0 2.0 4.0 0.0)) +(define light2pos #(0.0 0.0 4.0 0.0)) +(define diff-color 0) +(define diff-shape 0) + +(define color-map #(#(0.2 0.2 1.0 1.0) ; blue + #(1.0 0.5 0.0 1.0) ; orange + #(1.0 1.0 0.0 1.0) ; yellow + #(1.0 0.0 1.0 1.0) ; magenta + #(0.0 0.8 0.2 1.0) ; green + #(0.8 0.1 0.0 1.0) ; red + #(1.0 1.0 1.0 1.0) ; white + )) + +;; 4 x 4 matrices +(define unproject_matrix + '#(#(0.266667 0.0 0.0 0.0) + #(0.0 0.2 0.0 0.0) + #(0.0 0.0 -26.881655 30.769228) + #(0.0 0.0 -0.846154 1.0))) +;; 4 element vector +(define viewport #f) + +;; ----------------------------------------------------------------- +;; Defining window toolkit classes +;; ----------------------------------------------------------------- + +;; defines a new main window +(define jewel-frame% + (class* frame% () + + (define/augment (on-close) + (jewel-quit-game)) + + (define/override (on-subwindow-char window event) + (let* ([c (send event get-key-code)] + [needed-help? need-help?]) + (set! need-help? #f) + (cond + ;; ESCAPE character exits + [(eq? c 'escape) + (if (not (equal? gamestate 'GAME-OVER)) + (begin (set! freeze #f) (send *TIMER* start timer-interval) - ) - ) - ) - ) - ( (and (equal? gamestate 'DIFFICULTY) - (member c '(#\0 #\1 #\2 #\3 #\4)) - ) - (case c - ( (#\0) - (jewel-start-game 0) ) - ( (#\1) - (jewel-start-game 1) ) - ( (#\2) - (jewel-start-game 2) ) - ( (#\3) - (jewel-start-game 3) ) - ( (#\4) - (jewel-start-game 4) ) - ) - ) + (set! gamestate 'GAME-OVER)) + (begin (jewel-quit-game) + (send *MAIN_WINDOW* show #f)))] + [(eq? c #\space) + (if (equal? gamestate 'GAME-OVER) + (difficulty-ask) + (jewel-key-lock))] + [(or (eq? c #\h) (eq? c #\H)) + (show-jewel-help)] + [(or (eq? c #\p) (eq? c #\P)) + (when (equal? gamestate 'PLAYING) + (set! freeze (not freeze)) + (if freeze + (send *TIMER* stop) + (send *TIMER* start timer-interval)))] + [(and (equal? gamestate 'DIFFICULTY) + (member c '(#\0 #\1 #\2 #\3 #\4))) + (case c + [(#\0) (jewel-start-game 0)] + [(#\1) (jewel-start-game 1)] + [(#\2) (jewel-start-game 2)] + [(#\3) (jewel-start-game 3)] + [(#\4) (jewel-start-game 4)])] + [else + (case c + [(up) (jewel-key-move 0 -1)] + [(down) (jewel-key-move 0 +1)] + [(left) (jewel-key-move -1 0)] + [(right) (jewel-key-move +1 0)] + [(release) (set! need-help? needed-help?)] + [else (set! need-help? #t)])]))) - (else - (case c - [(up) (jewel-key-move 0 -1)] - [(down) (jewel-key-move 0 +1)] - [(left) (jewel-key-move -1 0)] - [(right) (jewel-key-move +1 0)] - [(release) (set! need-help? needed-help?)] - [else (set! need-help? #t)])) - ) - ) - ) - - (super-instantiate () ) - ) - ) - - - ; defines a new OpenGL canvas, handling mouse and rendering, etc - (define jewel-canvas% - (class* canvas% () - (inherit with-gl-context swap-gl-buffers) + (super-instantiate ()))) - (define initialised #f) +;; defines a new OpenGL canvas, handling mouse and rendering, etc +(define jewel-canvas% + (class* canvas% () + (inherit with-gl-context swap-gl-buffers) - (init-field (expose #f) - (realize #f) - (configure #f) - (mouse-press #f) - (mouse-motion #f) - (mouse-release #f) - ) - - (define/override (on-event e) - (with-gl-context - (lambda () - (cond - ; mouse down - ( (send e button-down? 'right) - (mouse-press 'right (send e get-x) (send e get-y)) - ) - ( (send e button-down? 'middle) - (mouse-press 'middle (send e get-x) (send e get-y)) - ) - ( (send e button-down? 'left) - (mouse-press 'left (send e get-x) (send e get-y)) - ) - ; mouse up - ( (send e button-up? 'right) - (mouse-release 'right (send e get-x) (send e get-y)) - ) - ( (send e button-up? 'middle) - (mouse-release 'middle (send e get-x) (send e get-y)) - ) - ( (send e button-up? 'left) - (mouse-release 'left (send e get-x) (send e get-y)) - ) - ; mouse motion - ( (eq? (send e get-event-type) 'motion) - (mouse-motion (send e get-x) (send e get-y)) - ) - ) - ) - ) - ) - + (define initialised #f) - (define/override (on-paint) - (with-gl-context - (lambda () - (when (and initialised expose) - (expose) - ) - (swap-gl-buffers) - ) - ) - ) + (init-field [expose #f] + [realize #f] + [configure #f] + [mouse-press #f] + [mouse-motion #f] + [mouse-release #f]) - (define/override (on-size width height) - (with-gl-context - (lambda () - (when (not initialised) - (begin - (realize) - (set! initialised #t) - ) - ) - (configure width height) - ) - ) - ) + (define/override (on-event e) + (with-gl-context + (lambda () + (cond + ;; mouse down + [(send e button-down? 'right) + (mouse-press 'right (send e get-x) (send e get-y))] + [(send e button-down? 'middle) + (mouse-press 'middle (send e get-x) (send e get-y))] + [(send e button-down? 'left) + (mouse-press 'left (send e get-x) (send e get-y))] + ;; mouse up + [(send e button-up? 'right) + (mouse-release 'right (send e get-x) (send e get-y))] + [(send e button-up? 'middle) + (mouse-release 'middle (send e get-x) (send e get-y))] + [(send e button-up? 'left) + (mouse-release 'left (send e get-x) (send e get-y))] + ;; mouse motion + [(eq? (send e get-event-type) 'motion) + (mouse-motion (send e get-x) (send e get-y))])))) - (let ([cfg (new gl-config%)]) - (send cfg set-multisample-size 4) - (send cfg set-stencil-size 1) - (super-new (style '(gl no-autoclear)) (gl-config cfg))) + (define/override (on-paint) + (with-gl-context + (lambda () + (when (and initialised expose) (expose)) + (swap-gl-buffers)))) - (inherit get-dc) - (unless (send (get-dc) get-gl-context) - (message-box "Error" - (string-append "Jewel requires OpenGL, but there was an error initializing" - " the OpenGL context. Maybe OpenGL is not supported by" - " the current display.") - #f - '(ok stop)) - (exit)) + (define/override (on-size width height) + (with-gl-context + (lambda () + (unless initialised (realize) (set! initialised #t)) + (configure width height)))) - ) + (let ([cfg (new gl-config%)]) + (send cfg set-multisample-size 4) + (send cfg set-stencil-size 1) + (super-new (style '(gl no-autoclear)) (gl-config cfg))) + + (inherit get-dc) + (unless (send (get-dc) get-gl-context) + (message-box "Error" + (string-append "Jewel requires OpenGL, but there was an error" + " initializing the OpenGL context. Maybe OpenGL is not" + " supported by the current display.") + #f + '(ok stop)) + (exit)))) + +;; ----------------------------------------------------------------- +;; element handling functions +;; ----------------------------------------------------------------- +(define element-db #f) +(define move-db #f) + +;; initialise one element +(define (element-init iy ix) + (let ([elem (vector-ref (vector-ref element-db iy) ix)] + [move (vector-ref move-db (+ iy 2))] + [type (random 7)]) + (hash-set! elem 'type type ) + (hash-set! elem 'angle (random 360) ) + (hash-set! elem 'ax 0.0 ) + (hash-set! elem 'ay 1.0 ) + (hash-set! elem 'az 0.0 ) + (hash-set! elem 'fall 0.0 ) + (hash-set! elem 'speed 0.0 ) + (hash-set! elem 'vanish 1.0 ) + (hash-set! elem 'dx 0.0 ) + (hash-set! elem 'dy 0.0 ) + (hash-set! elem 'swapping 0 ) + + (cond + ;; one color per type + ;; one shape for all type + [(= jewel-difficulty 1) + (hash-set! elem 'color type) + (hash-set! elem 'shape diff-shape)] + ;; one color for all type + ;; one shape per type + [(= jewel-difficulty 2) + (hash-set! elem 'color diff-color) + (hash-set! elem 'shape type)] + ;; one color per type + ;; random shape + [(= jewel-difficulty 3) + (hash-set! elem 'color type) + (hash-set! elem 'shape (random 7))] + ;; random color + ;; one shape per type + [(= jewel-difficulty 4) + (hash-set! elem 'color (random 7)) + (hash-set! elem 'shape type)] + ;; default + ;; one color per type + ;; one shape per type + [else + (hash-set! elem 'color type) + (hash-set! elem 'shape type)]) + + ;; set the element type in the move database + (vector-set! move (+ ix 2) type))) + +;; initialise the element database, N x N matrix +(define (element-init-db) + ;; initialise the move database + (set! move-db (make-vector (+ ey 4) #f)) + (for ([iy (in-range (+ ey 4))]) + (vector-set! move-db iy (make-vector (+ ex 4) -1))) + + (set! element-db (make-vector ey #f)) + (for ([iy (in-range ey)]) + (define row (make-vector ex #f)) + (vector-set! element-db iy row) + (for ([ix (in-range ex)]) + (vector-set! row ix (make-hash)) + (element-init iy ix)))) + +(define (element-get iy ix prop) + (hash-ref (vector-ref (vector-ref element-db iy) ix) + prop (lambda () #f))) + +(define (element-set! iy ix prop value) + (hash-set! (vector-ref (vector-ref element-db iy) ix) prop value)) + +(define (element-swap! iy ix jy jx) + (let* ([ri (vector-ref element-db iy)] + [rj (vector-ref element-db jy)] + [tt (vector-ref ri ix)] + ;; move array + [mi (vector-ref move-db (+ iy 2))] + [mj (vector-ref move-db (+ jy 2))] + [mt (vector-ref mi (+ ix 2))]) + (vector-set! ri ix (vector-ref rj jx)) + (vector-set! rj jx tt) + ;; move array + (vector-set! mi (+ ix 2) (vector-ref mj (+ jx 2))) + (vector-set! mj (+ jx 2) mt))) + +;; copy from i to j +(define (element-copy! iy ix jy jx) + (define elem1 (vector-ref (vector-ref element-db iy) ix)) + (define elem2 (vector-ref (vector-ref element-db jy) jx)) + (hash-for-each elem1 (lambda (key val) (hash-set! elem2 key val))) + ;; move array + (array-set! move-db (+ jy 2) (+ jx 2) + (array-ref move-db (+ iy 2) (+ ix 2)))) + +;; ----------------------------------------------------------------- +;; score number handling functions +;; ----------------------------------------------------------------- + +(define score-numbers (make-hash)) +(define score-key 0) +(define score-fade 0.01) + +(define (score-add x y z fade value) + (define elem (make-hash)) + (hash-set! elem 'x x) + (hash-set! elem 'y y) + (hash-set! elem 'z z) + (hash-set! elem 'fade fade) + (hash-set! elem 'value value) + (hash-set! score-numbers score-key elem) + (set! score-key (+ score-key 1))) + +(define (score-set! elem prop val) + (hash-set! elem prop val)) + +(define (score-del! score-key) + (hash-remove! score-numbers score-key)) + +(define (score-get elem prop) + (hash-ref elem prop)) + +(define (score-for-each proc table) + (hash-for-each table (lambda (key val) (proc key val)))) + +;; ----------------------------------------------------------------- +;; High score reading, writing and rendering +;; ----------------------------------------------------------------- + +;; split a string line at the ch character(s) into tokens +;; for example: +;; "hello ladies and gentleman" -> ("hello" "ladies" "and" "gentleman") +(define (text-split str ch empty) + (let* ([idx (string-length str)] + [last #f] + [slist '()]) + (do () ((not (>= idx 0))) + (set! last idx) + (do () ((not (and (> idx 0) + (not (char=? (string-ref str (- idx 1)) ch))))) + (set! idx (- idx 1))) + (when (>= idx 0) + (when (or empty (and (not empty) (> (- last idx) 0))) + (set! slist (cons (substring str idx last) slist))) + (set! idx (- idx 1)))) + slist)) + +(define (high-score-read) + (define l (get-preference 'plt:jewel:scores (lambda () null))) + (let loop ([l l] [i 0]) + (unless (or (not (pair? l)) + (not (list? (car l))) + (not (= (length (car l)) 3)) + (= i 10)) + (vector-set! high-scores i (map clean-string (car l))) + (loop (cdr l) (+ i 1))))) + +(define (high-score-write) + (put-preferences '(plt:jewel:scores) (list (vector->list high-scores)))) + +(define (get-user) + (define s + (get-text-from-user "High Score" "High Scorer's Name:" *MAIN_WINDOW* + (or (getenv "USER") (getenv "USERNAME")))) + (if s (clean-string s) "UKNOWN")) + +(define (clean-string s) + (regexp-replace* #rx"[^-A-Z0-9+]" + (let ([s (string-upcase s)]) + (substring s 0 (min (string-length s) 10))) + " ")) + +(define (high-score-set) + (define score #f) + (define exit? #f) + (do ((i 0 (+ i 1))) ((or exit? (= i (vector-length high-scores)))) + (set! score (vector-ref high-scores i)) + (when (> jewel-score (string->number (list-ref score 1))) + (do ((j (- (vector-length high-scores) 1) (- j 1))) + ((= j i)) + (vector-set! high-scores j (vector-ref high-scores (- j 1)))) + (vector-set! high-scores i + (list (get-user) + (number->string jewel-score) + (number->string jewel-level))) + (set! exit? #t)))) + +(define (high-score-render) + (define highxname 2.5) + (define highxscore 6.0) + (define highxlevel 5.5) + (define score #f) + (define dimmer #(0.0 0.0 0.0 0.5)) + (define boxleft -3.5) + (define boxright 8.2) + (define boxtop 5.7) + (define boxbottom (- boxtop)) + (define boxz 8.0) + (glPushMatrix) + (glTranslatef -3.0 5.5 8.1) + (glScalef 0.6 0.6 0.6) + + (glPushMatrix) + (glTranslatef highxname 0.0 0.0) + (string-draw "NAME") + (glTranslatef highxscore 0.0 0.0) + (string-draw "SCORE") + (glTranslatef highxlevel 0.0 0.0) + (string-draw "LEVEL") + (glPopMatrix) + + (for ([i (in-range (vector-length high-scores))]) + (glTranslatef 0.0 -1.8 0.0) + (glPushMatrix) + (set! score (vector-ref high-scores i)) + (string-draw (number->string (+ i 1)) ) + (glTranslatef highxname 0.0 0.0) + (string-draw (if (< (string-length (list-ref score 0)) 6) + (list-ref score 0) + (substring (list-ref score 0) 0 6))) + (glTranslatef (+ highxscore 1.0) 0.0 0.0) + (string-draw (list-ref score 1) ) + (glTranslatef highxlevel 0.0 0.0) + (string-draw (list-ref score 2) ) + (glPopMatrix)) + (glPopMatrix) + + ;; draw a dim square over the jewels + (glEnable GL_BLEND) + (when (>= (get-gl-version-number) 13) + (glEnable GL_MULTISAMPLE)) + (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector dimmer)) + (glDisable GL_LIGHT0) + (glDisable GL_LIGHT1) + (glBegin GL_QUADS) + (glVertex3f boxleft boxtop boxz) + (glVertex3f boxleft boxbottom boxz) + (glVertex3f boxright boxbottom boxz) + (glVertex3f boxright boxtop boxz) + (glEnd) + (glEnable GL_LIGHT0) + (glEnable GL_LIGHT1) + (glBlendFunc GL_ONE GL_ONE) + (glDisable GL_BLEND)) + +;; ----------------------------------------------------------------- +;; Difficulty level +;; ----------------------------------------------------------------- + +(define (difficulty-ask) + (set! gamestate 'DIFFICULTY)) + +(define (difficulty-render) + (define highxname 2.5) + (define highxscore 6.0) + (define highxlevel 5.5) + (define dimmer #(0.0 0.0 0.0 0.5)) + (define boxleft -3.5) + (define boxright 8.2) + (define boxtop 5.7) + (define boxbottom (- boxtop)) + (define boxz 8.0) + (define levels '#("BEGINNER" "MATCH EVERYTHING" + "EASY" "MATCH COLORS" + "MEDIUM" "MATCH SHAPES" + "HIGH" "MATCH COLORS" + "EXTREME" "MATCH SHAPES")) + + (glPushMatrix) + (glTranslatef -3.0 5.5 8.1) + (glScalef 0.6 0.6 0.6) + + (glPushMatrix) + (glTranslatef highxname 0.0 0.0) + (string-draw "SELECT DIFFICULTY") + (glPopMatrix) + + (for ([i (in-range (vector-length levels))]) + (glTranslatef 0.0 -1.8 0.0) + (glPushMatrix) + (when (= (remainder i 2) 0) + (string-draw (number->string (/ i 2)) )) + (glTranslatef highxname 0.0 0.0) + (string-draw (vector-ref levels i) ) + (glPopMatrix)) + (glPopMatrix) + + ;; draw a dim square over the jewels + (glEnable GL_BLEND) + (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector dimmer)) + (glDisable GL_LIGHT0) + (glDisable GL_LIGHT1) + (glBegin GL_QUADS) + (glVertex3f boxleft boxtop boxz) + (glVertex3f boxleft boxbottom boxz) + (glVertex3f boxright boxbottom boxz) + (glVertex3f boxright boxtop boxz) + (glEnd) + (glEnable GL_LIGHT0) + (glEnable GL_LIGHT1) + (glBlendFunc GL_ONE GL_ONE) + (glDisable GL_BLEND)) + +;; ----------------------------------------------------------------- +;; Initialisation +;; ----------------------------------------------------------------- + +(define (jewel-quit-game) + (send *TIMER* stop) + (high-score-write) + ;; (display "\nTHE END\n") ) - - ; ----------------------------------------------------------------- - ; element handling functions - ; ----------------------------------------------------------------- - (define element-db #f) - (define move-db #f) +(define (jewel-init-game) + (element-init-db) - ; initialise one element - (define (element-init iy ix) - (let - ( (elem (vector-ref (vector-ref element-db iy) ix)) - (move (vector-ref move-db (+ iy 2))) - (type (random 7)) - ) - (hash-set! elem 'type type ) - (hash-set! elem 'angle (random 360) ) - (hash-set! elem 'ax 0.0 ) - (hash-set! elem 'ay 1.0 ) - (hash-set! elem 'az 0.0 ) - (hash-set! elem 'fall 0.0 ) - (hash-set! elem 'speed 0.0 ) - (hash-set! elem 'vanish 1.0 ) - (hash-set! elem 'dx 0.0 ) - (hash-set! elem 'dy 0.0 ) - (hash-set! elem 'swapping 0 ) + (set! jewel-stage 0) + (set! jewel-score 0) + (set! jewel-level 0) + (set! jewel-nmoves 0) + (set! score-numbers (make-hash)) - (cond - ; one color per type - ; one shape for all type - ( (= jewel-difficulty 1) - (hash-set! elem 'color type) - (hash-set! elem 'shape diff-shape) - ) - ; one color for all type - ; one shape per type - ( (= jewel-difficulty 2) - (hash-set! elem 'color diff-color) - (hash-set! elem 'shape type) - ) - ; one color per type - ; random shape - ( (= jewel-difficulty 3) - (hash-set! elem 'color type) - (hash-set! elem 'shape (random 7)) - ) - ; random color - ; one shape per type - ( (= jewel-difficulty 4) - (hash-set! elem 'color (random 7)) - (hash-set! elem 'shape type) - ) - ; default - ; one color per type - ; one shape per type - ( else - (hash-set! elem 'color type) - (hash-set! elem 'shape type) - ) - ) - - ; set the element type in the move database - (vector-set! move (+ ix 2) type) - ) - ) + (set! gamestate 'GAME-OVER) + ;; read high scores + (high-score-read)) +(define (jewel-start-game diff) + (set! jewel-difficulty diff) + (set! jewel-life startlife) + (set! jewel-decay initialdecay) + (set! jewel-stage 0) + (set! jewel-score 0) + (set! jewel-level 0) + (set! jewel-nmoves 0) - ; initialise the element database, N x N matrix - (define (element-init-db) - ; initialise the move database - (set! move-db (make-vector (+ ey 4) #f)) - (do ((iy 0 (+ iy 1))) ((= iy (+ ey 4))) - (vector-set! move-db iy (make-vector (+ ex 4) -1)) - ) - - (set! element-db (make-vector ey #f)) - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (let* - ( (row (make-vector ex #f)) ) - (vector-set! element-db iy row) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (let* - ( (elem (make-hash)) ) - (vector-set! row ix elem) - (element-init iy ix) - ) - ) - ); end of let - ) - ) - + ;; make the current configuration to vanish + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (element-set! iy ix 'vanish 0.999)) - (define (element-get iy ix prop) - (hash-ref (vector-ref (vector-ref element-db iy) ix) - prop (lambda () #f)) - ) + (set! diff-color (random 7)) + (set! diff-shape (random 7)) + (set! gamestate 'PLAYING) + (set! action-mode 'ACTION-REMOVING)) +(define (jewel-realize) + (define scale 0.88) - (define (element-set! iy ix prop value) - (let* - ( (elem (vector-ref (vector-ref element-db iy) ix)) ) - (hash-set! elem prop value) - ) - ) + (glEnable GL_CULL_FACE) + (glEnable GL_LIGHTING) + (glEnable GL_LIGHT0) + (glEnable GL_LIGHT1) + (glLightfv GL_LIGHT0 GL_SPECULAR (vector->gl-float-vector white)) + (glLightfv GL_LIGHT0 GL_DIFFUSE (vector->gl-float-vector grey)) - (define (element-swap! iy ix jy jx) - (let* - ( (ri (vector-ref element-db iy)) - (rj (vector-ref element-db jy)) - (tt (vector-ref ri ix)) - ; move array - (mi (vector-ref move-db (+ iy 2))) - (mj (vector-ref move-db (+ jy 2))) - (mt (vector-ref mi (+ ix 2))) - ) - (vector-set! ri ix (vector-ref rj jx)) - (vector-set! rj jx tt) - ; move array - (vector-set! mi (+ ix 2) (vector-ref mj (+ jx 2))) - (vector-set! mj (+ jx 2) mt) - ) - ) + (glLightfv GL_LIGHT1 GL_SPECULAR (vector->gl-float-vector white2)) + (glLightfv GL_LIGHT1 GL_DIFFUSE (vector->gl-float-vector grey2)) + (glLightfv GL_LIGHT2 GL_SPECULAR (vector->gl-float-vector white)) + (glLightfv GL_LIGHT2 GL_DIFFUSE (vector->gl-float-vector grey)) - ; copy from i to j - (define (element-copy! iy ix jy jx) - (let* - ( (elem1 (vector-ref (vector-ref element-db iy) ix)) - (elem2 (vector-ref (vector-ref element-db jy) jx)) - ) - (hash-for-each - elem1 - (lambda (key val) (hash-set! elem2 key val)) - ) - ; move array - (array-set! move-db (+ jy 2) (+ jx 2) - (array-ref move-db (+ iy 2) (+ ix 2)) - ) - ) - ) + (glEnable GL_DEPTH_TEST) - ; ----------------------------------------------------------------- - ; score number handling functions - ; ----------------------------------------------------------------- + (glShadeModel GL_SMOOTH) + (glClearColor 0.0 0.0 0.0 1.0) + (glClear GL_COLOR_BUFFER_BIT) + (glClear GL_DEPTH_BUFFER_BIT) - (define score-numbers (make-hash)) - (define score-key 0) - (define score-fade 0.01) + (glDisable GL_BLEND) + (glBlendFunc GL_ONE GL_ONE) - (define (score-add x y z fade value) - (let* - ( (elem (make-hash)) ) - (hash-set! elem 'x x) - (hash-set! elem 'y y) - (hash-set! elem 'z z) - (hash-set! elem 'fade fade) - (hash-set! elem 'value value) - - (hash-set! score-numbers score-key elem) - (set! score-key (+ score-key 1)) - ) - ) - - (define (score-set! elem prop val) - (hash-set! elem prop val) - ) + (glLineWidth 2.0) + (glDisable GL_LINE_SMOOTH) - (define (score-del! score-key) - (hash-remove! score-numbers score-key) - ) + ;; initialise objects + (set! objectlists (glGenLists 8)) + (glNewList (+ objectlists 0) GL_COMPILE) + (makebucky (* scale 0.9)) + (glEndList) - (define (score-get elem prop) - (hash-ref elem prop) - ) + (glNewList (+ objectlists 1) GL_COMPILE) + (makebevelcube scale) + (glEndList) - (define (score-for-each proc table) - (hash-for-each - table - (lambda (key val) (proc key val)) - ) - ) + (glNewList (+ objectlists 2) GL_COMPILE) + (makepyramid (* scale 0.7)) + (glEndList) - ; ----------------------------------------------------------------- - ; High score reading, writing and rendering - ; ----------------------------------------------------------------- + (glNewList (+ objectlists 3) GL_COMPILE) + (makeicosahedron (* scale 0.9)) + ;; (makespiky (* scale 0.9)) + (glEndList) - ; split a string line at the ch character(s) into tokens - ; for example: - ; "hello ladies and gentleman" -> ("hello" "ladies" "and" "gentleman") - (define (text-split str ch empty) - (let* - ((idx (string-length str)) - (last #f) - (slist '()) - ) - (do () ( (not (>= idx 0)) ) - (set! last idx) - (do () ( (not (and (> idx 0) - (not (char=? (string-ref str (- idx 1)) ch)) - ) - ) ) - (set! idx (- idx 1)) - ) - (when (>= idx 0) - (begin - (when (or empty - (and (not empty) (> (- last idx) 0)) ) - (set! slist (cons (substring str idx last) slist)) - ) - (set! idx (- idx 1)) - ) - ) - ) - slist - ) - ) + (glNewList (+ objectlists 4) GL_COMPILE) + (makecylinder (* scale 0.9)) + (glEndList) + (glNewList (+ objectlists 5) GL_COMPILE) + (makediamond (* scale 0.9)) + (glEndList) - (define (high-score-read) - (let ([l (get-preference 'plt:jewel:scores (lambda () null))]) - (let loop ([l l][i 0]) - (unless (or (not (pair? l)) - (not (list? (car l))) - (not (= (length (car l)) 3)) - (= i 10)) - (vector-set! high-scores i (map clean-string (car l))) - (loop (cdr l) (+ i 1)))))) + (glNewList (+ objectlists 6) GL_COMPILE) + (makeuvsphere (* scale 0.9)) + (glEndList) + (glNewList (+ objectlists 7) GL_COMPILE) + (makedisc (* scale 1.2)) + (glEndList) - (define (high-score-write) - (put-preferences '(plt:jewel:scores) (list (vector->list high-scores)))) - - (define (get-user) - (let ([s (get-text-from-user "High Score" - "High Scorer's Name:" - *MAIN_WINDOW* - (or (getenv "USER") - (getenv "USERNAME")))]) - (if s - (clean-string s) - "UKNOWN"))) + ;; initialise fonts + (string-init font-scale)) - (define (clean-string s) - (regexp-replace* #rx"[^-A-Z0-9+]" - (let ([s (string-upcase s)]) - (substring s 0 (min (string-length s) 10))) - " ")) +(define (jewel-configure width height) + (glViewport 0 0 width height) + (set! viewport (make-vector 4 0)) + (vector-set! viewport 2 width) + (vector-set! viewport 3 height) - (define (high-score-set) - (let* - ( (score #f) - (exit? #f) - ) + ;; projection matrix + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) + (if (< width height) + (let ([h (/ height width)]) + (glFrustum -1.0 1.0 (- h) h 5.0 60.0)) + (let ((h (/ width height))) + (glFrustum (- h) h -1.0 1.0 5.0 60.0))) + ;; modelview matrix + (glMatrixMode GL_MODELVIEW) + (glLoadIdentity) + (glTranslatef 0.0 0.0 -40.0)) - (do ((i 0 (+ i 1))) ((or exit? (= i (vector-length high-scores)))) - (set! score (vector-ref high-scores i)) - (when (> jewel-score (string->number (list-ref score 1))) - (begin - (do ((j (- (vector-length high-scores) 1) (- j 1))) - ((= j i)) - (vector-set! high-scores j (vector-ref high-scores (- j 1))) - ) - (vector-set! high-scores i - (list (get-user) - (number->string jewel-score) - (number->string jewel-level))) - (set! exit? #t) - ) - ) - ) - ) - ) - - - (define (high-score-render) - (let* - ( (highxname 2.5) - (highxscore 6.0) - (highxlevel 5.5) - (score #f) - (dimmer #(0.0 0.0 0.0 0.5)) - (boxleft -3.5) - (boxright 8.2) - (boxtop 5.7) - (boxbottom (- boxtop)) - (boxz 8.0) - ) - (glPushMatrix) - (glTranslatef -3.0 5.5 8.1) - (glScalef 0.6 0.6 0.6) - - (glPushMatrix) - (glTranslatef highxname 0.0 0.0) - (string-draw "NAME") - (glTranslatef highxscore 0.0 0.0) - (string-draw "SCORE") - (glTranslatef highxlevel 0.0 0.0) - (string-draw "LEVEL") - (glPopMatrix) - - (do ((i 0 (+ i 1))) ((= i (vector-length high-scores))) - (glTranslatef 0.0 -1.8 0.0) - (glPushMatrix) - (set! score (vector-ref high-scores i)) - (string-draw (number->string (+ i 1)) ) - (glTranslatef highxname 0.0 0.0) - (if (< (string-length (list-ref score 0)) 6) - (string-draw (list-ref score 0) ) - (string-draw (substring (list-ref score 0) 0 6) ) - ) - (glTranslatef (+ highxscore 1.0) 0.0 0.0) - (string-draw (list-ref score 1) ) - (glTranslatef highxlevel 0.0 0.0) - (string-draw (list-ref score 2) ) - (glPopMatrix) - ) - (glPopMatrix) +;; ----------------------------------------------------------------- +;; Handling animation and game control +;; ----------------------------------------------------------------- - ; draw a dim square over the jewels - (glEnable GL_BLEND) - (when (>= (get-gl-version-number) 13) - (glEnable GL_MULTISAMPLE)) - (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector dimmer)) - (glDisable GL_LIGHT0) - (glDisable GL_LIGHT1) - (glBegin GL_QUADS) - (glVertex3f boxleft boxtop boxz) - (glVertex3f boxleft boxbottom boxz) - (glVertex3f boxright boxbottom boxz) - (glVertex3f boxright boxtop boxz) - (glEnd) - (glEnable GL_LIGHT0) - (glEnable GL_LIGHT1) - (glBlendFunc GL_ONE GL_ONE) - (glDisable GL_BLEND) - ) - ) - - - ; ----------------------------------------------------------------- - ; Difficulty level - ; ----------------------------------------------------------------- - - (define (difficulty-ask) - (set! gamestate 'DIFFICULTY) - ) - - (define (difficulty-render) - (let* - ( (highxname 2.5) - (highxscore 6.0) - (highxlevel 5.5) - (dimmer #(0.0 0.0 0.0 0.5)) - (boxleft -3.5) - (boxright 8.2) - (boxtop 5.7) - (boxbottom (- boxtop)) - (boxz 8.0) - (levels #("BEGINNER" - "MATCH EVERYTHING" - "EASY" - "MATCH COLORS" - "MEDIUM" - "MATCH SHAPES" - "HIGH" - "MATCH COLORS" - "EXTREME" - "MATCH SHAPES" - )) - ) - (glPushMatrix) - (glTranslatef -3.0 5.5 8.1) - (glScalef 0.6 0.6 0.6) - - (glPushMatrix) - (glTranslatef highxname 0.0 0.0) - (string-draw "SELECT DIFFICULTY") - (glPopMatrix) - - (do ((i 0 (+ i 1))) ((= i (vector-length levels))) - (glTranslatef 0.0 -1.8 0.0) - (glPushMatrix) - (when (= (remainder i 2) 0) - (string-draw (number->string (/ i 2)) ) - ) - (glTranslatef highxname 0.0 0.0) - (string-draw (vector-ref levels i) ) - (glPopMatrix) - ) - (glPopMatrix) +;; determine which elements to replace +(define (replace) + (define falls (make-vector ex 1)) + (do ((iy (- ey 1) (- iy 1))) ((< iy 0)) + (for ([ix (in-range ex)]) + (when (= (element-get iy ix 'vanish) 0.0) + (define finished -1) + (do ((k (- iy 1) (- k 1))) ((or (< k 0) (> finished -1))) + (unless (= (element-get k ix 'vanish) 0.0) + (set! finished k))) + (if (>= finished 0) + (begin (element-copy! finished ix iy ix) + (element-set! finished ix 'vanish 0.0) + (element-set! iy ix 'fall (- iy finished))) + ;; initializes new elements + (begin (element-init iy ix) + (element-set! iy ix 'fall (+ iy (vector-ref falls ix))) + (vector-set! falls ix (+ 1 (vector-ref falls ix))))))))) - ; draw a dim square over the jewels - (glEnable GL_BLEND) - (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector dimmer)) - (glDisable GL_LIGHT0) - (glDisable GL_LIGHT1) - (glBegin GL_QUADS) - (glVertex3f boxleft boxtop boxz) - (glVertex3f boxleft boxbottom boxz) - (glVertex3f boxright boxbottom boxz) - (glVertex3f boxright boxtop boxz) - (glEnd) - (glEnable GL_LIGHT0) - (glEnable GL_LIGHT1) - (glBlendFunc GL_ONE GL_ONE) - (glDisable GL_BLEND) - ) - ) - - - ; ----------------------------------------------------------------- - ; Initialisation - ; ----------------------------------------------------------------- +(define (addlife chain len x y) + (define value (+ chain len)) + (define sx (+ (* (+ (- x (/ ex 2.0)) 0.5) spacing) shiftx)) + (define sy (+ (* (- (/ ey 2.0) y) spacing) shifty)) + (define sz 0.0) + (score-add sx sy sz 1.0 value) + (set! jewel-score (+ jewel-score value)) + (set! jewel-stage (+ jewel-stage len)) + (set! jewel-life (+ jewel-life (* value credit))) + (when (>= jewel-stage nextlevel) + (set! jewel-stage (- jewel-stage nextlevel)) + (set! jewel-level (+ jewel-level 1)) + (set! jewel-decay (+ jewel-decay decayadd)))) - (define (jewel-quit-game) - (send *TIMER* stop) - (high-score-write) -; (display "\nTHE END\n") - ) - - - (define (jewel-init-game) - (element-init-db) - - (set! jewel-stage 0) - (set! jewel-score 0) - (set! jewel-level 0) - (set! jewel-nmoves 0) - (set! score-numbers (make-hash)) +(define (declife) + (unless (eq? gamestate 'GAME-OVER) + (set! jewel-life (- jewel-life jewel-decay)) + (when (< jewel-life 0.0) + (define score #f) + (define exit? #f) + ;; set life points to zero + (set! jewel-life 0.0) + ;; set high score if any + (high-score-set) + ;; end of game + (set! gamestate 'GAME-OVER)))) - (set! gamestate 'GAME-OVER) - ;read high scores - (high-score-read) - ) - - - (define (jewel-start-game diff) - (set! jewel-difficulty diff) - (set! jewel-life startlife) - (set! jewel-decay initialdecay) - (set! jewel-stage 0) - (set! jewel-score 0) - (set! jewel-level 0) - (set! jewel-nmoves 0) +;; check for minimum three adjacent elements +(define (findwins checking) + (define hadsome #f) + ;; check the rows for three identical elements + (for ([iy (in-range ey)]) + (define identical 1) + (do ((ix 1 (+ ix 1))) ((= ix (+ ex 1))) + ;; if in range horizontally and + ;; type of the current and the previous element is equal + (if (and (< ix ex) + (= (element-get iy ix 'type) + (element-get iy (- ix 1) 'type))) + (set! identical (+ identical 1)) + ;; else three or more identical has been found in a row + (if (>= identical 3) + (begin (set! hadsome #t) + (when (not checking) + (let* ([x (- ix 1 (/ identical 2.0))] + [y (+ iy 0.5)]) + (addlife 0 (- identical 1) x y))) + ;; set the found elements to vanish + (do ((k identical (- k 1))) ((= k 0)) + (element-set! iy (- ix k) 'vanish 0.999)) + (set! identical 1)) + (set! identical 1))))) - ; make the current configuration to vanish - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (element-set! iy ix 'vanish 0.999) - ) - ) + ;; checking columns for three identical elements + (for ([ix (in-range ex)]) + (define identical 1) + (do ((iy 1 (+ iy 1))) ((= iy (+ ey 1))) + ;; if in range vertically and + ;; type of the current and the previous element is equal + (if (and (< iy ey) + (= (element-get iy ix 'type) + (element-get (- iy 1) ix 'type))) + (set! identical (+ identical 1)) + ;; else three or more identical has been found in a row + (if (>= identical 3) + (begin (set! hadsome #t) + (when (not checking) + (let ([x ix] + [y (- iy 0.5 (/ identical 2.0))]) + (addlife 0 (- identical 1) x y))) + ;; set the found elements to vanish + (do ((k identical (- k 1))) ((= k 0)) + (element-set! (- iy k) ix 'vanish 0.999)) + (set! identical 1)) + (set! identical 1))))) + hadsome) - (set! diff-color (random 7)) - (set! diff-shape (random 7)) - (set! gamestate 'PLAYING) - (set! action-mode 'ACTION-REMOVING) - ) - - - (define (jewel-realize) - (let* - ( ( scale 0.88) ) +;; possible moves +(define chkpos + '#( #(1 -1 0 1) + #(-1 -1 -1 1) + #(0 -1 1 1) + #(0 -2 0 1) - (glEnable GL_CULL_FACE) - (glEnable GL_LIGHTING) - (glEnable GL_LIGHT0) - (glEnable GL_LIGHT1) + #(1 1 -1 0) + #(1 -1 -1 -1) + #(1 0 -1 1) + #(2 0 -1 0) - (glLightfv GL_LIGHT0 GL_SPECULAR (vector->gl-float-vector white)) - (glLightfv GL_LIGHT0 GL_DIFFUSE (vector->gl-float-vector grey)) + #(-1 1 0 -1) + #(1 1 1 -1) + #(0 1 -1 -1) + #(0 2 0 -1) - (glLightfv GL_LIGHT1 GL_SPECULAR (vector->gl-float-vector white2)) - (glLightfv GL_LIGHT1 GL_DIFFUSE (vector->gl-float-vector grey2)) + #(-1 -1 1 0) + #(-1 1 1 1) + #(-1 0 1 -1) + #(-2 0 1 0))) - (glLightfv GL_LIGHT2 GL_SPECULAR (vector->gl-float-vector white)) - (glLightfv GL_LIGHT2 GL_DIFFUSE (vector->gl-float-vector grey)) +;; check whether any move is possible in the game field +(define (anymove?) + (define moves 0) + (define type #f) - (glEnable GL_DEPTH_TEST) + ;; check for all combination + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (unless (= (element-get iy ix 'type) + (array-ref move-db (+ iy 2) (+ ix 2))) + (printf "wrong iy: ~s ix: ~s\n" iy ix)) + ;; all 16, possible combinations + (for ([k (in-range 16)]) + (set! type (array-ref move-db (+ iy 2) (+ ix 2))) + (when (and (= type (array-ref move-db + (+ iy 2 (array-ref chkpos k 1)) + (+ ix 2 (array-ref chkpos k 0)))) + (= type (array-ref move-db + (+ iy 2 (array-ref chkpos k 3)) + (+ ix 2 (array-ref chkpos k 2))))) + ;; (printf "move ~s\n" type) + ;; (printf "~s - ~s\n" iy ix) + ;; (printf "~s - ~s\n" + ;; (+ iy (array-ref chkpos k 1)) + ;; (+ ix (array-ref chkpos k 0))) + ;; (printf "~s - ~s\n" + ;; (+ iy (array-ref chkpos k 3)) + ;; (+ ix (array-ref chkpos k 2))) + (set! moves (+ moves 1))))) + (set! jewel-nmoves moves) + moves) - (glShadeModel GL_SMOOTH) - (glClearColor 0.0 0.0 0.0 1.0) - (glClear GL_COLOR_BUFFER_BIT) - (glClear GL_DEPTH_BUFFER_BIT) +;; function that is called by the timer +;; handles the switching between states +(define (jewel-control-game) + ;; continuous rotation of elements + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (element-set! iy ix 'angle (+ 3.0 (element-get iy ix 'angle)))) - (glDisable GL_BLEND) - (glBlendFunc GL_ONE GL_ONE) + ;; fading of score numbers + (score-for-each + (lambda (key elem) + (define fade (- (score-get elem 'fade) score-fade)) + (if (< fade 0.0) + (score-del! key) + (score-set! elem 'fade fade))) + score-numbers) - (glLineWidth 2.0) - (glDisable GL_LINE_SMOOTH) - - ; initialise objects - (set! objectlists (glGenLists 8)) - (glNewList (+ objectlists 0) GL_COMPILE) - (makebucky (* scale 0.9)) - (glEndList) - - (glNewList (+ objectlists 1) GL_COMPILE) - (makebevelcube scale) - (glEndList) - - (glNewList (+ objectlists 2) GL_COMPILE) - (makepyramid (* scale 0.7)) - (glEndList) - - (glNewList (+ objectlists 3) GL_COMPILE) - (makeicosahedron (* scale 0.9)) -; (makespiky (* scale 0.9)) - (glEndList) - - (glNewList (+ objectlists 4) GL_COMPILE) - (makecylinder (* scale 0.9)) - (glEndList) - - (glNewList (+ objectlists 5) GL_COMPILE) - (makediamond (* scale 0.9)) - (glEndList) - - (glNewList (+ objectlists 6) GL_COMPILE) - (makeuvsphere (* scale 0.9)) - (glEndList) - - (glNewList (+ objectlists 7) GL_COMPILE) - (makedisc (* scale 1.2)) - (glEndList) - - ; initialise fonts - (string-init font-scale) - ) - ) - - - (define (jewel-configure width height) - (glViewport 0 0 width height) - (set! viewport (make-vector 4 0)) - (vector-set! viewport 2 width) - (vector-set! viewport 3 height) - - ; projection matrix - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) - (if (< width height) - (let ( (h (/ height width)) ) - (glFrustum -1.0 1.0 (- h) h 5.0 60.0) - ) - (let ( (h (/ width height)) ) - (glFrustum (- h) h -1.0 1.0 5.0 60.0) - ) - ) - ; modelview matrix - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - (glTranslatef 0.0 0.0 -40.0) - ) - - ; ----------------------------------------------------------------- - ; Handling animation and game control - ; ----------------------------------------------------------------- - - ; determine which elements to replace - (define (replace) - (let* - ( (falls (make-vector ex 1)) ) - - (do ((iy (- ey 1) (- iy 1))) ((< iy 0)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - - (when (= (element-get iy ix 'vanish) 0.0) - (let ( (finished -1) ) - (do ((k (- iy 1) (- k 1))) ((or (< k 0) (> finished -1))) - (when (not (= (element-get k ix 'vanish) 0.0)) - (set! finished k) - ) - ) - (if (>= finished 0) + (case action-mode + [(ACTION-LOOKING) + (when (equal? gamestate 'PLAYING) + (if (findwins #f) + (set! action-mode 'ACTION-REMOVING) + ;; check if any move is possible at all ??? + (begin + (if (= (anymove?) 0) + ;; set all elements to vanish + (begin + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (element-set! iy ix 'vanish 0.999)) + (set! action-mode 'ACTION-REMOVING)) + ;; switch to ACTION-WAITING + (set! action-mode 'ACTION-WAITING)))))] + [(ACTION-WAITING) + (when (equal? gamestate 'PLAYING) + (declife) + (when tryswap? (set! action-mode 'ACTION-SWAPPING)))] + [(ACTION-SWAPPING ACTION-UNSWAPPING) + (when (equal? action-mode 'ACTION-UNSWAPPING) + (declife)) + (set! tryswap? #f) + (let* ([hadsome 0] [swap #f] + [ax #f] [ay #f] [bx #f] [by #f]) + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (set! swap (element-get iy ix 'swapping)) + (when (not (= swap 0)) + (set! hadsome 1) + (set! swap (+ swap 1)) + (if (= swap swaptime) (begin - (element-copy! finished ix iy ix) - (element-set! finished ix 'vanish 0.0) - (element-set! iy ix 'fall (- iy finished)) - ) - (begin - ; initializes new elements - (element-init iy ix) - (element-set! iy ix 'fall (+ iy (vector-ref falls ix))) - (vector-set! falls ix (+ 1 (vector-ref falls ix))) - ) - ) - ) - ) ; end of if - - ) ; end of do - ) ; end of do - ) ; end of let - ) - - - (define (addlife chain len x y) - (let* - ( (value (+ chain len)) - (sx (+ (* (+ (- x (/ ex 2.0)) 0.5) spacing) shiftx)) - (sy (+ (* (- (/ ey 2.0) y) spacing) shifty)) - (sz 0.0) - ) - (score-add sx sy sz 1.0 value) - (set! jewel-score (+ jewel-score value)) - (set! jewel-stage (+ jewel-stage len)) - (set! jewel-life (+ jewel-life (* value credit))) - (when (>= jewel-stage nextlevel) - (begin - (set! jewel-stage (- jewel-stage nextlevel)) - (set! jewel-level (+ jewel-level 1)) - (set! jewel-decay (+ jewel-decay decayadd)) - ) - ) - ) - ) - - - (define (declife) - (unless (eq? gamestate 'GAME-OVER) - (set! jewel-life (- jewel-life jewel-decay)) - (when (< jewel-life 0.0) - (let* ( (score #f) (exit? #f) ) - ; set life points to zero - (set! jewel-life 0.0) - ; set high score if any - (high-score-set) - ; end of game - (set! gamestate 'GAME-OVER) - ) - ) - ) - ) - - ;check for minimum three adjacent elements - (define (findwins checking) - (let* - ( (hadsome #f) ) - ; check the rows for three identical elements - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (let* - ( (identical 1) ) - (do ((ix 1 (+ ix 1))) ((= ix (+ ex 1))) - ; if in range horizontally and - ; type of the current and the previous element is equal - (if (and (< ix ex) - (= (element-get iy ix 'type) - (element-get iy (- ix 1) 'type))) - (set! identical (+ identical 1)) - ; else three or more identical has been found in a row - (if (>= identical 3) - (begin - (set! hadsome #t) - (when (not checking) - (let* - ( (x (- ix 1 (/ identical 2.0))) - (y (+ iy 0.5)) - ) - (addlife 0 (- identical 1) x y) - ) - ) - ; set the found elements to vanish - (do ((k identical (- k 1))) ((= k 0)) - (element-set! iy (- ix k) 'vanish 0.999) - ) - (set! identical 1) - ) - (set! identical 1) - ) - ) - ) - ) - ) ; end of checking rows - - ; checking columns for three identical elements - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (let* - ( (identical 1) ) - (do ((iy 1 (+ iy 1))) ((= iy (+ ey 1))) - ; if in range vertically and - ; type of the current and the previous element is equal - (if (and (< iy ey) - (= (element-get iy ix 'type) - (element-get (- iy 1) ix 'type))) - (set! identical (+ identical 1)) - ; else three or more identical has been found in a row - (if (>= identical 3) - (begin - (set! hadsome #t) - (when (not checking) - (let* - ( (x ix) - (y (- iy 0.5 (/ identical 2.0))) - ) - (addlife 0 (- identical 1) x y) - ) - ) - ; set the found elements to vanish - (do ((k identical (- k 1))) ((= k 0)) - (element-set! (- iy k) ix 'vanish 0.999) - ) - (set! identical 1) - ) - (set! identical 1) - ) - ) - ) - ) - ) ; end of checking columns - - hadsome - ) - ) - - - ; possible moves - (define chkpos - '#( #(1 -1 0 1) - #(-1 -1 -1 1) - #(0 -1 1 1) - #(0 -2 0 1) - - #(1 1 -1 0) - #(1 -1 -1 -1) - #(1 0 -1 1) - #(2 0 -1 0) - - #(-1 1 0 -1) - #(1 1 1 -1) - #(0 1 -1 -1) - #(0 2 0 -1) - - #(-1 -1 1 0) - #(-1 1 1 1) - #(-1 0 1 -1) - #(-2 0 1 0) - ) - ) - - ; check whether any move is possible in the game field - (define (anymove?) - (let* - ( (moves 0) - (type #f) - ) - - ; check for all combination - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (when (not (= (element-get iy ix 'type) - (array-ref move-db (+ iy 2) (+ ix 2)))) - (begin - (display "wrong iy: ")(display iy) - (display " ix: ")(display ix)(newline) - ) - ) - ; all 16, possible combinations - (do ((k 0 (+ k 1))) ((= k 16)) - (set! type (array-ref move-db (+ iy 2) (+ ix 2))) - (when (and (= type (array-ref move-db - (+ iy 2 (array-ref chkpos k 1)) - (+ ix 2 (array-ref chkpos k 0)))) - (= type (array-ref move-db - (+ iy 2 (array-ref chkpos k 3)) - (+ ix 2 (array-ref chkpos k 2)))) - ) - (begin - #| - (display "move ")(display type)(newline) - (display iy)(display " - ")(display ix)(newline) - (display (+ iy (array-ref chkpos k 1)))(display " - ") - (display (+ ix (array-ref chkpos k 0)))(newline) - (display (+ iy (array-ref chkpos k 3)))(display " - ") - (display (+ ix (array-ref chkpos k 2)))(newline) - |# - (set! moves (+ moves 1)) - ) - ) - ) - ) - ) - - (set! jewel-nmoves moves) - - moves - ) - ) - - - ; function that is called by the timer - ; handles the switching between states - (define (jewel-control-game) - - ; continuous rotation of elements - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (element-set! iy ix 'angle (+ 3.0 (element-get iy ix 'angle))) - ) - ) - - ; fading of score numbers - (score-for-each - (lambda (key elem) - (let* - ( (fade (- (score-get elem 'fade) score-fade)) ) - (if (< fade 0.0) - (score-del! key) - (score-set! elem 'fade fade) - ) - ) - ) - score-numbers - ) - - (case action-mode - ( (ACTION-LOOKING) - (when (equal? gamestate 'PLAYING) - (if (findwins #f) - (set! action-mode 'ACTION-REMOVING) - ; check if any move is possible at all ??? - (begin - (if (= (anymove?) 0) - ; set all elements to vanish - (begin - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (element-set! iy ix 'vanish 0.999) - ) - ) - (set! action-mode 'ACTION-REMOVING) - ) - ; switch to ACTION-WAITING - (set! action-mode 'ACTION-WAITING) - ) - ) - ) - ) - ) - ( (ACTION-WAITING) - (when (equal? gamestate 'PLAYING) - (begin - (declife) - (when tryswap? - (set! action-mode 'ACTION-SWAPPING) - ) - ) - ) - ) - ( (ACTION-SWAPPING ACTION-UNSWAPPING) - (when (equal? action-mode 'ACTION-UNSWAPPING) - (declife) - ) - (set! tryswap? #f) - (let* - ( (hadsome 0) (swap #f) - (ax #f) (ay #f) (bx #f) (by #f) - ) - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (set! swap (element-get iy ix 'swapping)) - (when (not (= swap 0)) - (begin - (set! hadsome 1) - (set! swap (+ swap 1)) - (if (= swap swaptime) - (begin - (element-set! iy ix 'swapping 0) - (set! hadsome 2) - ; for the first time it has no meaning - (set! ax bx) - (set! ay by) - ; it always stores the result in bx by - (set! bx ix) - (set! by iy) - ) - (element-set! iy ix 'swapping swap) - ) - ) - ) - ) - ) - + (element-set! iy ix 'swapping 0) + (set! hadsome 2) + ;; for the first time it has no meaning + (set! ax bx) + (set! ay by) + ;; it always stores the result in bx by + (set! bx ix) + (set! by iy)) + (element-set! iy ix 'swapping swap)))) (when (= hadsome 2) (cond - ( (findwins #f) - (set! locked? #f) - (set! action-mode 'ACTION-REMOVING) ) - ( (equal? action-mode 'ACTION-SWAPPING) - ; swap back - (element-swap! ay ax by bx) - ; set swapping - (element-set! ay ax 'swapping 1) - (element-set! ay ax 'dx (- (element-get ay ax 'dx))) - (element-set! ay ax 'dy (- (element-get ay ax 'dy))) - (element-set! by bx 'swapping 1) - (element-set! by bx 'dx (- (element-get by bx 'dx))) - (element-set! by bx 'dy (- (element-get by bx 'dy))) - ; unswapping state - (when revert-bubble-x - (set! bubble-x revert-bubble-x) - (set! bubble-y revert-bubble-y)) - (set! action-mode 'ACTION-UNSWAPPING) - ) - ( else - (set! locked? #f) - (set! action-mode 'ACTION-WAITING) ) - ) - ) - ) - ) - ; remove elements from the scene - ; after removal switch to dropping - ( (ACTION-REMOVING) - (let* - ( (hadsome 0) - (vanish #f) - ) - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (set! vanish (element-get iy ix 'vanish)) - (when (< vanish 1.0) - (begin - (set! vanish (- vanish vanishrate)) - (if (< vanish 0.0) - (begin - (element-set! iy ix 'vanish 0.0) - (set! hadsome (+ hadsome 1)) - ) - (element-set! iy ix 'vanish vanish) - ) - ) - ) - ) - ) - (when (> hadsome 0) - (begin - (replace) - (set! action-mode 'ACTION-DROPPING) - ) - ) - ) - ) ; end of ACTION-REMOVING - ; drop in new elements to the scene - ; after dropping switch to looking - ( (ACTION-DROPPING) - (let* - ( (hadsome 0) - (fall #f) - (speed #f) - ) - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (set! fall (element-get iy ix 'fall)) - (when (> fall 0.0) - (begin - (set! hadsome (+ hadsome 1)) - (set! fall (- fall (element-get iy ix 'speed))) - (set! speed (element-get iy ix 'speed)) - (element-set! iy ix 'speed (+ speed fallrate)) - (if (<= fall 0.0) - (begin - (element-set! iy ix 'fall 0.0) - (element-set! iy ix 'speed 0.0) - ) - (element-set! iy ix 'fall fall) - ) - ) - ) - ) - ) - (when (= hadsome 0) - (set! action-mode 'ACTION-LOOKING) - ) - ); end of let - ) ; end of ACTION-DROPPING - ) - - ; generate an expose event, redraw the opengl window - (queue-callback - (lambda x (send *OPENGL_WINDOW* on-paint)) - #f - ) - ) + [(findwins #f) + (set! locked? #f) + (set! action-mode 'ACTION-REMOVING)] + [(equal? action-mode 'ACTION-SWAPPING) + ;; swap back + (element-swap! ay ax by bx) + ;; set swapping + (element-set! ay ax 'swapping 1) + (element-set! ay ax 'dx (- (element-get ay ax 'dx))) + (element-set! ay ax 'dy (- (element-get ay ax 'dy))) + (element-set! by bx 'swapping 1) + (element-set! by bx 'dx (- (element-get by bx 'dx))) + (element-set! by bx 'dy (- (element-get by bx 'dy))) + ;; unswapping state + (when revert-bubble-x + (set! bubble-x revert-bubble-x) + (set! bubble-y revert-bubble-y)) + (set! action-mode 'ACTION-UNSWAPPING)] + [else + (set! locked? #f) + (set! action-mode 'ACTION-WAITING)])))] + ;; remove elements from the scene + ;; after removal switch to dropping + [(ACTION-REMOVING) + (define hadsome 0) + (define vanish #f) + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (set! vanish (element-get iy ix 'vanish)) + (when (< vanish 1.0) + (set! vanish (- vanish vanishrate)) + (if (< vanish 0.0) + (begin (element-set! iy ix 'vanish 0.0) + (set! hadsome (+ hadsome 1))) + (element-set! iy ix 'vanish vanish)))) + (when (> hadsome 0) + (replace) + (set! action-mode 'ACTION-DROPPING))] + ;; drop in new elements to the scene + ;; after dropping switch to looking + [(ACTION-DROPPING) + (define hadsome 0) + (define fall #f) + (define speed #f) + (for* ([iy (in-range ey)] [ix (in-range ex)]) + (set! fall (element-get iy ix 'fall)) + (when (> fall 0.0) + (set! hadsome (+ hadsome 1)) + (set! fall (- fall (element-get iy ix 'speed))) + (set! speed (element-get iy ix 'speed)) + (element-set! iy ix 'speed (+ speed fallrate)) + (if (<= fall 0.0) + (begin (element-set! iy ix 'fall 0.0) + (element-set! iy ix 'speed 0.0)) + (element-set! iy ix 'fall fall)))) + (when (= hadsome 0) (set! action-mode 'ACTION-LOOKING))]) + ;; generate an expose event, redraw the opengl window + (queue-callback + (lambda x (send *OPENGL_WINDOW* on-paint)) + #f)) - ; ----------------------------------------------------------------- - ; Rendering functions - ; ----------------------------------------------------------------- +;; ----------------------------------------------------------------- +;; Rendering functions +;; ----------------------------------------------------------------- - (define (setmaterial color-vect) - (glMaterialfv GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector color-vect)) - (glMaterialfv GL_FRONT_AND_BACK GL_SPECULAR - (vector->gl-float-vector white)) - (glMaterialfv GL_FRONT_AND_BACK GL_SHININESS - (vector->gl-float-vector #(25.0))) - ) +(define (setmaterial color-vect) + (glMaterialfv GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector color-vect)) + (glMaterialfv GL_FRONT_AND_BACK GL_SPECULAR + (vector->gl-float-vector white)) + (glMaterialfv GL_FRONT_AND_BACK GL_SHININESS + (vector->gl-float-vector #(25.0)))) - - (define (show-life) - (let* - ( (sections 24) - (section-yellow 4) - (section-red 1) - (b (/ (* 3.1415927 2.0) 24)) - (a 0) - (s #f) - ) - (glPushMatrix) - (glTranslatef -6.5 -3.0 5.0) - (glRotatef 11.0 0.0 1.0 0.0) - - ; circle outline - (setmaterial (vector-ref color-map 0)) - (glNormal3f 0.0 0.0 1.0) - (glBegin GL_LINE_LOOP) - (do ((i 0 (+ i 1))) ((= i sections)) - (glVertex3f (* (sin a) 2.0) - (* (cos a) 2.0) - 0.0) - (set! a (+ a b)) - ) - (glEnd) - - ; show triangle fan - (glBegin GL_TRIANGLE_FAN) - (glEnable GL_NORMALIZE) - (glVertex3f 0.0 0.0 3.0) - (if (< jewel-life lifevisible) - (let* - ( (x #f) (y #f) ) - (set! a (/ (* 3.1415927 2.0 jewel-life) lifevisible)) - (set! x (* (sin a) 2.0)) - (set! y (* (cos a) 2.0)) - (glNormal3f x y 0.7) - (glVertex3f x y 0.0) - (set! s (floor (/ (* jewel-life sections) lifevisible))) - ) - (set! s sections) - ) - ; color of the section - (cond - ( (> s section-yellow) - ; green - (setmaterial (vector-ref color-map 4)) - ) - ( (> s section-red) - ; yellow - (setmaterial (vector-ref color-map 2)) - ) - ( else - ; red - (setmaterial (vector-ref color-map 5)) - ) - ) - (do ((i s (- i 1))) ((< i 0)) - (cond - ( (= i section-yellow) (setmaterial (vector-ref color-map 2))) - ( (= i section-red) (setmaterial (vector-ref color-map 5))) - ) - (set! a (* (- i 0.5) b)) - (glNormal3f (sin a) (cos a) 0.7) - (set! a (* i b)) - (glVertex3f (* (sin a) 2.0) - (* (cos a) 2.0) - 0.0) - ) - - (glEnd) - - (glPopMatrix) - ) - ) - - ; main OpenGL rendering, called by expose event - (define (jewel-redraw) - (glClear GL_COLOR_BUFFER_BIT) - (glClear GL_DEPTH_BUFFER_BIT) - - (glLightfv GL_LIGHT0 GL_POSITION (vector->gl-float-vector lightpos)) - (glLightfv GL_LIGHT1 GL_POSITION (vector->gl-float-vector light1pos)) - (glLightfv GL_LIGHT2 GL_POSITION (vector->gl-float-vector light2pos)) - - (when (equal? gamestate 'PLAYING) - (show-life) - ) - +(define (show-life) + (let* ([sections 24] + [section-yellow 4] + [section-red 1] + [b (/ (* 3.1415927 2.0) 24)] + [a 0] + [s #f]) (glPushMatrix) - - (let* - ( (t spacing) - (x #f) - (y (* t (- (/ ey 2.0) 0.5))) - (xt 0.0) (yt 0.0) (zt 0.0) - (k (* ex ey)) - (nx #f) (ny #f) (nz #f) - (obj #f) - (ang #f) - (s #f) - (counter 0) - - ) + (glTranslatef -6.5 -3.0 5.0) + (glRotatef 11.0 0.0 1.0 0.0) - ;; This shouldn't do anything, but it fixes drawing in - ;; Snow Leopard. Bug in the game or in Snow Leopard? - (glEnable GL_LIGHT2) - (glDisable GL_LIGHT2) - - (glEnable GL_BLEND) - (do ((iy 0 (+ iy 1))) ((= iy ey)) - (set! x (* (- t) (- (/ ex 2.0) 0.5))) - (do ((ix 0 (+ ix 1))) ((= ix ex)) - (set! nx (+ x shiftx)) - (set! ny y) - (set! nz (* (- 1.0 (element-get iy ix 'vanish)) 50.0)) - (when (not (= (element-get iy ix 'swapping) 0)) - (begin - (set! ang (/ (* (element-get iy ix 'swapping) 3.1415927) - 2.0 - swaptime)) - (set! s (* t (cos ang))) - (set! nx (+ nx (* s (element-get iy ix 'dx)))) - (set! ny (+ ny (* s (element-get iy ix 'dy)))) - (set! s (* t (sin (* ang 2.0)))) - (when (= (remainder counter 2) 1) - (set! s (- s)) - ) - (set! counter (+ counter 1)) - (set! nz (+ nz s)) - ) - ) - (set! ny (+ ny (* (element-get iy ix 'fall) t))) - - (glTranslatef (- nx xt) (- ny yt) (- nz zt)) - (set! xt nx) - (set! yt ny) - (set! zt nz) + ;; circle outline + (setmaterial (vector-ref color-map 0)) + (glNormal3f 0.0 0.0 1.0) + (glBegin GL_LINE_LOOP) + (for ([i (in-range sections)]) + (glVertex3f (* (sin a) 2.0) (* (cos a) 2.0) 0.0) + (set! a (+ a b))) + (glEnd) - (when (and (equal? gamestate 'PLAYING) + ;; show triangle fan + (glBegin GL_TRIANGLE_FAN) + (glEnable GL_NORMALIZE) + (glVertex3f 0.0 0.0 3.0) + (if (< jewel-life lifevisible) + (let ([x #f] [y #f]) + (set! a (/ (* 3.1415927 2.0 jewel-life) lifevisible)) + (set! x (* (sin a) 2.0)) + (set! y (* (cos a) 2.0)) + (glNormal3f x y 0.7) + (glVertex3f x y 0.0) + (set! s (floor (/ (* jewel-life sections) lifevisible)))) + (set! s sections)) + ;; color of the section + (cond [(> s section-yellow) + ;; green + (setmaterial (vector-ref color-map 4))] + [(> s section-red) + ;; yellow + (setmaterial (vector-ref color-map 2))] + [else + ;; red + (setmaterial (vector-ref color-map 5))]) + (do ((i s (- i 1))) ((< i 0)) + (cond [(= i section-yellow) (setmaterial (vector-ref color-map 2))] + [(= i section-red) (setmaterial (vector-ref color-map 5))]) + (set! a (* (- i 0.5) b)) + (glNormal3f (sin a) (cos a) 0.7) + (set! a (* i b)) + (glVertex3f (* (sin a) 2.0) (* (cos a) 2.0) 0.0)) + + (glEnd) + + (glPopMatrix))) + +;; main OpenGL rendering, called by expose event +(define (jewel-redraw) + (glClear GL_COLOR_BUFFER_BIT) + (glClear GL_DEPTH_BUFFER_BIT) + + (glLightfv GL_LIGHT0 GL_POSITION (vector->gl-float-vector lightpos)) + (glLightfv GL_LIGHT1 GL_POSITION (vector->gl-float-vector light1pos)) + (glLightfv GL_LIGHT2 GL_POSITION (vector->gl-float-vector light2pos)) + + (when (equal? gamestate 'PLAYING) (show-life)) + + (glPushMatrix) + + (let* ([t spacing] + [x #f] + [y (* t (- (/ ey 2.0) 0.5))] + [xt 0.0] [yt 0.0] [zt 0.0] + [k (* ex ey)] + [nx #f] [ny #f] [nz #f] + [obj #f] + [ang #f] + [s #f] + [counter 0]) + + ;; This shouldn't do anything, but it fixes drawing in + ;; Snow Leopard. Bug in the game or in Snow Leopard? + (glEnable GL_LIGHT2) + (glDisable GL_LIGHT2) + + (glEnable GL_BLEND) + (for ([iy (in-range ey)]) + (set! x (* (- t) (- (/ ex 2.0) 0.5))) + (for ([ix (in-range ex)]) + (set! nx (+ x shiftx)) + (set! ny y) + (set! nz (* (- 1.0 (element-get iy ix 'vanish)) 50.0)) + (when (not (= (element-get iy ix 'swapping) 0)) + (set! ang (/ (* (element-get iy ix 'swapping) 3.1415927) + 2.0 + swaptime)) + (set! s (* t (cos ang))) + (set! nx (+ nx (* s (element-get iy ix 'dx)))) + (set! ny (+ ny (* s (element-get iy ix 'dy)))) + (set! s (* t (sin (* ang 2.0)))) + (when (= (remainder counter 2) 1) (set! s (- s))) + (set! counter (+ counter 1)) + (set! nz (+ nz s))) + (set! ny (+ ny (* (element-get iy ix 'fall) t))) + (glTranslatef (- nx xt) (- ny yt) (- nz zt)) + (set! xt nx) + (set! yt ny) + (set! zt nz) + (when (and (equal? gamestate 'PLAYING) (= cposx ix) (= cposy iy)) - (begin - (glEnable GL_LIGHT2) - ) - ) - - (glPushMatrix) - (glRotatef (element-get iy ix 'angle) - (element-get iy ix 'ax) - (element-get iy ix 'ay) - (element-get iy ix 'az)) - - (setmaterial (vector-ref color-map (element-get iy ix 'color))) - (glCallList (+ objectlists (element-get iy ix 'shape))) - - (glPopMatrix) + (glEnable GL_LIGHT2)) + (glPushMatrix) + (glRotatef (element-get iy ix 'angle) + (element-get iy ix 'ax) + (element-get iy ix 'ay) + (element-get iy ix 'az)) + (setmaterial (vector-ref color-map (element-get iy ix 'color))) + (glCallList (+ objectlists (element-get iy ix 'shape))) - (when (and (equal? gamestate 'PLAYING) + (glPopMatrix) + + (when (and (equal? gamestate 'PLAYING) (= cposx ix) (= cposy iy)) - (glDisable GL_LIGHT2) - ) + (glDisable GL_LIGHT2)) - (when (and (equal? gamestate 'PLAYING) - (not (memq action-mode '(ACTION-REMOVING ACTION-DROPPING ACTION-LOOKING))) - bubble-x bubble-y - (= ix bubble-x) - (= iy bubble-y)) - (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) - (glPushMatrix) - (setmaterial (if locked? bubble-lock-color bubble-color)) - (glCallList (+ objectlists 7)) - (glPopMatrix) - (glBlendFunc GL_ONE GL_ONE)) - - (set! x (+ x t)) - ) - (set! y (- y t)) - ) - ) - - (glPopMatrix) - - ; draw the flying scores - (glDisable GL_DEPTH_TEST) - (score-for-each - (lambda (key elem) - (let* - ( (color (make-vector 4 1.0)) - (fade (score-get elem 'fade)) - (x (score-get elem 'x)) - (y (score-get elem 'y)) - (z (score-get elem 'z)) - (val (score-get elem 'value)) - ) - (vector-set! color 0 fade) - (vector-set! color 1 fade) - (vector-set! color 2 fade) + (when (and (equal? gamestate 'PLAYING) + (not (memq action-mode '(ACTION-REMOVING + ACTION-DROPPING + ACTION-LOOKING))) + bubble-x bubble-y + (= ix bubble-x) + (= iy bubble-y)) + (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) (glPushMatrix) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector color)) - (glTranslatef x (- y (- 1.0 fade)) z) - (string-draw (string-append "+" (number->string val)) ) + (setmaterial (if locked? bubble-lock-color bubble-color)) + (glCallList (+ objectlists 7)) (glPopMatrix) - ) - ) - score-numbers - ) - (glEnable GL_DEPTH_TEST) - - ; draw the scores on the left hand side - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector (vector-ref color-map 5))) - (glPushMatrix) - (glTranslatef scorex scorey scorez) - (glScalef 0.8 0.8 0.8) - (string-draw "SCORE") - (glTranslatef 0.0 (- linespace) 0.0) - (string-draw "LEVEL") - (glTranslatef 0.0 (- linespace) 0.0) - (string-draw "MOVES") - (cond - ( (equal? gamestate 'GAME-OVER) - (glTranslatef 0.0 (* -2.5 linespace) 0.0) - (glScalef 0.6 0.6 0.6) - (string-draw "GAME OVER") - (glTranslatef 0.0 (* -1.5 linespace) 0.0) - (glScalef 0.5 0.5 0.5) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector grey)) - (string-draw "SPACE BAR TO START") - (glTranslatef 0.0 (* -0.6 linespace) 0.0) - (string-draw "H FOR HELP") - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector (vector-ref color-map 5))) - ) - ( (and (equal? gamestate 'PLAYING) - need-help?) - (glTranslatef 0.0 (* -3.75 linespace) 0.0) - (glScalef 0.3 0.3 0.3) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector grey)) - (string-draw "DRAG JEWEL WITH MOUSE OR USE ARROW KEYS AND SPACE BAR H FOR HELP") - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector (vector-ref color-map 5)))) - ) - (glPopMatrix) - - (glPushMatrix) - (glTranslatef scorex - (- scorey (* linespace 0.4)) - scorez) - (glScalef 0.8 0.8 0.8) - (string-draw (number->string jewel-score) ) - (glTranslatef 0.0 (- linespace) 0.0) - (string-draw (number->string jewel-level) ) - (glTranslatef 0.0 (- linespace) 0.0) - (string-draw (number->string jewel-nmoves) ) - (glPopMatrix) + (glBlendFunc GL_ONE GL_ONE)) - (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE - (vector->gl-float-vector (vector-ref color-map 6))) - ; if not playing cover with dim square - (when (equal? gamestate 'GAME-OVER) - (high-score-render) - ) - - (when (equal? gamestate 'DIFFICULTY) - (difficulty-render) - ) - ) + (set! x (+ x t))) + (set! y (- y t)))) - ; ----------------------------------------------------------------- - ; Mouse handling - ; ----------------------------------------------------------------- + (glPopMatrix) - (define last-click-x #f) - (define last-click-y #f) - (define num-unproductive-clicks 0) + ;; draw the flying scores + (glDisable GL_DEPTH_TEST) + (score-for-each + (lambda (key elem) + (let* ([color (make-vector 4 1.0)] + [fade (score-get elem 'fade)] + [x (score-get elem 'x)] + [y (score-get elem 'y)] + [z (score-get elem 'z)] + [val (score-get elem 'value)]) + (vector-set! color 0 fade) + (vector-set! color 1 fade) + (vector-set! color 2 fade) + (glPushMatrix) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector color)) + (glTranslatef x (- y (- 1.0 fade)) z) + (string-draw (string-append "+" (number->string val)) ) + (glPopMatrix))) + score-numbers) + (glEnable GL_DEPTH_TEST) - (define (jewel-mouse-down button x y) - (set! down-x x) - (set! down-y y) - (set! isdown? #t) - (set! num-unproductive-clicks (add1 num-unproductive-clicks)) - (set! need-help? (num-unproductive-clicks . > . 5)) - (let ([pos (getpos x y)]) - (when pos - (set! last-click-x (vector-ref pos 0)) - (set! last-click-y (vector-ref pos 1)))) - (set! bubble-x #f) - (set! bubble-y #f) - (set! revert-bubble-x #f) - (set! revert-bubble-y #f) - ) + ;; draw the scores on the left hand side + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector (vector-ref color-map 5))) + (glPushMatrix) + (glTranslatef scorex scorey scorez) + (glScalef 0.8 0.8 0.8) + (string-draw "SCORE") + (glTranslatef 0.0 (- linespace) 0.0) + (string-draw "LEVEL") + (glTranslatef 0.0 (- linespace) 0.0) + (string-draw "MOVES") + (cond + [(equal? gamestate 'GAME-OVER) + (glTranslatef 0.0 (* -2.5 linespace) 0.0) + (glScalef 0.6 0.6 0.6) + (string-draw "GAME OVER") + (glTranslatef 0.0 (* -1.5 linespace) 0.0) + (glScalef 0.5 0.5 0.5) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector grey)) + (string-draw "SPACE BAR TO START") + (glTranslatef 0.0 (* -0.6 linespace) 0.0) + (string-draw "H FOR HELP") + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector (vector-ref color-map 5)))] + [(and (equal? gamestate 'PLAYING) need-help?) + (glTranslatef 0.0 (* -3.75 linespace) 0.0) + (glScalef 0.3 0.3 0.3) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector grey)) + (string-draw "DRAG JEWEL WITH MOUSE OR USE ARROW KEYS AND SPACE BAR H FOR HELP") + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector (vector-ref color-map 5)))]) + (glPopMatrix) + (glPushMatrix) + (glTranslatef scorex (- scorey (* linespace 0.4)) scorez) + (glScalef 0.8 0.8 0.8) + (string-draw (number->string jewel-score) ) + (glTranslatef 0.0 (- linespace) 0.0) + (string-draw (number->string jewel-level) ) + (glTranslatef 0.0 (- linespace) 0.0) + (string-draw (number->string jewel-nmoves) ) + (glPopMatrix) - (define (jewel-mouse-up button x y) - (set! isdown? #f) - ) - - (define (jewel-key-move dx dy) - (if (and locked? - (equal? gamestate 'PLAYING) - (equal? action-mode 'ACTION-WAITING) - bubble-x - bubble-y - (<= 0 (+ bubble-x dx) (sub1 ex)) - (<= 0 (+ bubble-y dy) (sub1 ey))) - (let ([bx bubble-x] - [by bubble-y]) - (set! revert-bubble-x bx) - (set! revert-bubble-y by) - (set! bubble-x (+ bubble-x dx)) - (set! bubble-y (+ bubble-y dy)) - (try-to-swap bx by dx dy)) - (begin - (set! revert-bubble-x #f) - (set! revert-bubble-y #f) - (set! bubble-x - (cond - [bubble-x (max 0 (min (sub1 ex) (+ bubble-x dx)))] - [last-click-x last-click-x] - [(dx . >= . 0) 0] - [else (- ex 1)])) - (set! bubble-y - (cond - [bubble-y (max 0 (min (sub1 ex) (+ bubble-y dy)))] - [last-click-y last-click-y] - [(dy . >= . 0) 0] - [else (- ey 1)])))) - (set! isdown? #f) - ) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector (vector-ref color-map 6))) + ;; if not playing cover with dim square + (when (equal? gamestate 'GAME-OVER) (high-score-render)) + (when (equal? gamestate 'DIFFICULTY) (difficulty-render))) - (define (jewel-key-lock) - (set! locked? (not locked?)) - (set! isdown? #f) - ) - - - ; from the mouse position determine which object will be selected - (define (getpos mx my) - - (let* - ( (screen (make-vector 4)) - (v0 (vector-ref viewport 0)) - (v1 (vector-ref viewport 1)) - (v2 (vector-ref viewport 2)) - (v3 (vector-ref viewport 3)) - (world #f) - ) - (vector-set! screen 0 (- (/ (* (- mx v0) 2.0) v2) 1.0)) - (vector-set! screen 1 (- (/ (* (- my v1) 2.0) v3) 1.0)) - (vector-set! screen 2 0.27272727) - (vector-set! screen 3 1.0) - - (set! world (array-mult-vector unproject_matrix screen)) - - (if (= (vector-ref world 3) 0.0) - (make-vector 2 -1) - (let* - ( (w0 (vector-ref world 0)) - (w1 (vector-ref world 1)) - (w2 (vector-ref world 2)) - (w3 (vector-ref world 3)) - (z (/ w2 w3)) - (x (+ (/ (- (* z (/ w0 w3)) shiftx) spacing) (/ ex 2))) - (y (+ (/ (- (* z (/ w1 w3)) shifty) spacing) (/ ey 2))) - (vect (make-vector 2 0)) - ) - (if (>= x 0.0) - (set! x (inexact->exact (truncate x))) - (set! x -1) - ) - (if (>= y 0.0) - (set! y (inexact->exact (truncate y))) - (set! y -1) - ) - (vector-set! vect 0 x) - (vector-set! vect 1 y) - - vect - ) - ) - ) - ) +;; ----------------------------------------------------------------- +;; Mouse handling +;; ----------------------------------------------------------------- +(define last-click-x #f) +(define last-click-y #f) +(define num-unproductive-clicks 0) - (define (jewel-mouse-motion x y) - (let* - ( (pos (getpos x y)) - (dx (if isdown? (- x down-x) 0.0)) - (dy (if isdown? (- y down-y) 0.0)) - (px #f) - (py #f) - ) - (set! cposx (vector-ref pos 0)) - (set! cposy (vector-ref pos 1)) - - ; if mouse was pressed, - ; we are playing, - ; no action is happening - ; and mouse is moved, so try to swap - (when (and isdown? +(define (jewel-mouse-down button x y) + (set! down-x x) + (set! down-y y) + (set! isdown? #t) + (set! num-unproductive-clicks (add1 num-unproductive-clicks)) + (set! need-help? (num-unproductive-clicks . > . 5)) + (let ([pos (getpos x y)]) + (when pos + (set! last-click-x (vector-ref pos 0)) + (set! last-click-y (vector-ref pos 1)))) + (set! bubble-x #f) + (set! bubble-y #f) + (set! revert-bubble-x #f) + (set! revert-bubble-y #f)) + +(define (jewel-mouse-up button x y) + (set! isdown? #f)) + +(define (jewel-key-move dx dy) + (if (and locked? + (equal? gamestate 'PLAYING) + (equal? action-mode 'ACTION-WAITING) + bubble-x + bubble-y + (<= 0 (+ bubble-x dx) (sub1 ex)) + (<= 0 (+ bubble-y dy) (sub1 ey))) + (let ([bx bubble-x] [by bubble-y]) + (set! revert-bubble-x bx) + (set! revert-bubble-y by) + (set! bubble-x (+ bubble-x dx)) + (set! bubble-y (+ bubble-y dy)) + (try-to-swap bx by dx dy)) + (begin + (set! revert-bubble-x #f) + (set! revert-bubble-y #f) + (set! bubble-x + (cond [bubble-x (max 0 (min (sub1 ex) (+ bubble-x dx)))] + [last-click-x last-click-x] + [(dx . >= . 0) 0] + [else (- ex 1)])) + (set! bubble-y + (cond [bubble-y (max 0 (min (sub1 ex) (+ bubble-y dy)))] + [last-click-y last-click-y] + [(dy . >= . 0) 0] + [else (- ey 1)])))) + (set! isdown? #f)) + +(define (jewel-key-lock) + (set! locked? (not locked?)) + (set! isdown? #f)) + +;; from the mouse position determine which object will be selected +(define (getpos mx my) + (let* ([screen (make-vector 4)] + [v0 (vector-ref viewport 0)] + [v1 (vector-ref viewport 1)] + [v2 (vector-ref viewport 2)] + [v3 (vector-ref viewport 3)] + [world #f]) + (vector-set! screen 0 (- (/ (* (- mx v0) 2.0) v2) 1.0)) + (vector-set! screen 1 (- (/ (* (- my v1) 2.0) v3) 1.0)) + (vector-set! screen 2 0.27272727) + (vector-set! screen 3 1.0) + + (set! world (array-mult-vector unproject_matrix screen)) + + (if (= (vector-ref world 3) 0.0) + (make-vector 2 -1) + (let* ([w0 (vector-ref world 0)] + [w1 (vector-ref world 1)] + [w2 (vector-ref world 2)] + [w3 (vector-ref world 3)] + [z (/ w2 w3)] + [x (+ (/ (- (* z (/ w0 w3)) shiftx) spacing) (/ ex 2))] + [y (+ (/ (- (* z (/ w1 w3)) shifty) spacing) (/ ey 2))] + [vect (make-vector 2 0)]) + (set! x (if (>= x 0.0) (inexact->exact (truncate x)) -1)) + (set! y (if (>= y 0.0) (inexact->exact (truncate y)) -1)) + (vector-set! vect 0 x) + (vector-set! vect 1 y) + vect)))) + +(define (jewel-mouse-motion x y) + (let* ([pos (getpos x y)] + [dx (if isdown? (- x down-x) 0.0)] + [dy (if isdown? (- y down-y) 0.0)] + [px #f] + [py #f]) + (set! cposx (vector-ref pos 0)) + (set! cposy (vector-ref pos 1)) + + ;; if mouse was pressed, + ;; we are playing, + ;; no action is happening + ;; and mouse is moved, so try to swap + (when (and isdown? (equal? gamestate 'PLAYING) (equal? action-mode 'ACTION-WAITING) - (> (+ (* dx dx) (* dy dy)) (* dist dist)) - ) - (begin - (set! isdown? #f) - (if (> (abs dx) (abs dy)) - (begin - (if (< dx 0) - (set! dx -1) - (set! dx 1) - ) - (set! dy 0) - ) - (begin - (if (< dy 0) - (set! dy -1) - (set! dy 1) - ) - (set! dx 0) - ) - ) - - (set! pos (getpos down-x down-y)) - (set! px (vector-ref pos 0)) - (set! py (vector-ref pos 1)) - (when (not (or (< px 0.0) - (>= px ex) - (< py 0.0) - (>= py ey) - (< (+ px dx) 0.0) - (>= (+ px dx) ex) - (< (+ py dy) 0.0) - (>= (+ py dy) ey))) - (set! num-unproductive-clicks 0) - (set! need-help? #f) - (try-to-swap px py dx dy) - ) - ) - ) - ) - ) + (> (+ (* dx dx) (* dy dy)) (* dist dist))) + (set! isdown? #f) + (if (> (abs dx) (abs dy)) + (begin (set! dx (if (< dx 0) -1 1)) + (set! dy 0)) + (begin (set! dy (if (< dy 0) -1 1)) + (set! dx 0))) - (define (try-to-swap px py dx dy) - (element-swap! py px (+ py dy) (+ px dx)) - ;; mark the elements for the swap - (element-set! py px 'swapping 1) - (element-set! py px 'dx dx) - (element-set! py px 'dy (- dy)) - (element-set! (+ py dy) (+ px dx) 'swapping 1) - (element-set! (+ py dy) (+ px dx) 'dx (- dx)) - (element-set! (+ py dy) (+ px dx) 'dy dy) - (set! tryswap? #t)) + (set! pos (getpos down-x down-y)) + (set! px (vector-ref pos 0)) + (set! py (vector-ref pos 1)) + (unless (or (< px 0.0) + (>= px ex) + (< py 0.0) + (>= py ey) + (< (+ px dx) 0.0) + (>= (+ px dx) ex) + (< (+ py dy) 0.0) + (>= (+ py dy) ey)) + (set! num-unproductive-clicks 0) + (set! need-help? #f) + (try-to-swap px py dx dy))))) - ; ----------------------------------------------------------------- - ; MAIN - ; ----------------------------------------------------------------- +(define (try-to-swap px py dx dy) + (element-swap! py px (+ py dy) (+ px dx)) + ;; mark the elements for the swap + (element-set! py px 'swapping 1) + (element-set! py px 'dx dx) + (element-set! py px 'dy (- dy)) + (element-set! (+ py dy) (+ px dx) 'swapping 1) + (element-set! (+ py dy) (+ px dx) 'dx (- dx)) + (element-set! (+ py dy) (+ px dx) 'dy dy) + (set! tryswap? #t)) - (jewel-init-game) +;; ----------------------------------------------------------------- +;; MAIN +;; ----------------------------------------------------------------- - (define show-jewel-help - (show-scribbling '(lib "games/scribblings/games.scrbl") "jewel")) +(jewel-init-game) - (define *MAIN_WINDOW* - (new jewel-frame% - (label "Jewel") - (min-width 640) - (min-height 480) - (stretchable-width #f) - (stretchable-height #f) - (style '(no-resize-border)) - ) - ) +(define show-jewel-help + (show-scribbling '(lib "games/scribblings/games.scrbl") "jewel")) - (define *OPENGL_WINDOW* - (new jewel-canvas% (parent *MAIN_WINDOW*) - (min-width 100) - (min-height 100) - (expose jewel-redraw) - (realize jewel-realize) - (configure jewel-configure) - (mouse-press jewel-mouse-down) - (mouse-motion jewel-mouse-motion) - (mouse-release jewel-mouse-up) - ) - ) +(define *MAIN_WINDOW* + (new jewel-frame% + [label "Jewel"] + [min-width 640] + [min-height 480] + [stretchable-width #f] + [stretchable-height #f] + [style '(no-resize-border)])) - (send *MAIN_WINDOW* show #t) - - (define *TIMER* (new timer% - (notify-callback jewel-control-game) - (interval timer-interval) - (just-once? #f) - ) - ) +(define *OPENGL_WINDOW* + (new jewel-canvas% + [parent *MAIN_WINDOW*] + [min-width 100] + [min-height 100] + [expose jewel-redraw] + [realize jewel-realize] + [configure jewel-configure] + [mouse-press jewel-mouse-down] + [mouse-motion jewel-mouse-motion] + [mouse-release jewel-mouse-up])) -))) +(send *MAIN_WINDOW* show #t) + +(define *TIMER* (new timer% + [notify-callback jewel-control-game] + [interval timer-interval] + [just-once? #f])) + +)) diff --git a/collects/games/jewel/shapes.rkt b/collects/games/jewel/shapes.rkt index 791d2ab660..7f154f3329 100644 --- a/collects/games/jewel/shapes.rkt +++ b/collects/games/jewel/shapes.rkt @@ -1,130 +1,111 @@ -(module shapes racket +#lang racket -(require sgl/gl - sgl/gl-vectors - sgl) +(require sgl/gl sgl/gl-vectors sgl) -(provide makedots makebucky makebevelcube makecylinder +(provide makedots makebucky makebevelcube makecylinder makeuvsphere makediamond makepyramid makeicosahedron makespiky makedisc) - (define (norm p1 p2 p3 dir) - (let* - ( (v1 (map (lambda (x y) (- x y)) p2 p1)) - (v2 (map (lambda (x y) (- x y)) p3 p1)) - (nx (- (* (list-ref v1 1) (list-ref v2 2)) - (* (list-ref v2 1) (list-ref v1 2)))) - (ny (- (* (list-ref v2 0) (list-ref v1 2)) - (* (list-ref v1 0) (list-ref v2 2)))) - (nz (- (* (list-ref v1 0) (list-ref v2 1)) - (* (list-ref v2 0) (list-ref v1 1)))) - ) - (glNormal3f (* dir nx) (* dir ny) (* dir nz)) - ) -) - - -; ------------------------------------------------------------------- + (let* ([v1 (map (lambda (x y) (- x y)) p2 p1)] + [v2 (map (lambda (x y) (- x y)) p3 p1)] + [nx (- (* (list-ref v1 1) (list-ref v2 2)) + (* (list-ref v2 1) (list-ref v1 2)))] + [ny (- (* (list-ref v2 0) (list-ref v1 2)) + (* (list-ref v1 0) (list-ref v2 2)))] + [nz (- (* (list-ref v1 0) (list-ref v2 1)) + (* (list-ref v2 0) (list-ref v1 1)))]) + (glNormal3f (* dir nx) (* dir ny) (* dir nz)))) + +;; ------------------------------------------------------------------- (define (makedots size) - (let* - ( (dots 12) - (a #f) (u #f) (v #f) - ) + (let* ([dots 12] + [a #f] [u #f] [v #f]) (glPointSize 3.0) (glDisable GL_LIGHTING) (glBegin GL_POINTS) - (do ((i 0 (+ i 1))) ((= i dots)) + (for ([i (in-range dots)]) (set! a (* i 3.1415928 (/ 2.0 dots))) (set! u (* size (cos a))) (set! v (* size (sin a))) (glVertex3f u v 0.0) - (glVertex3f u 0.0 v) - ) + (glVertex3f u 0.0 v)) (glEnd) - (glEnable GL_LIGHTING) - ) -) + (glEnable GL_LIGHTING))) - -; ------------------------------------------------------------------- +;; ------------------------------------------------------------------- (define bucky-points -'#( -(-0.449358 0.730026 0.514918 ) -(-0.277718 0.201774 0.939234 ) -(-0.277718 -0.201774 0.939234 ) -(-0.555436 0.403548 0.727076 ) -(-0.555436 -0.403548 0.727076 ) -(-0.833155 0.201774 0.514918 ) -(-0.833155 -0.201774 0.514918 ) -(0.106079 -0.326477 0.939234 ) -(0.212158 -0.652955 0.727076 ) -(-0.449358 -0.730026 0.514918 ) -(-0.065560 -0.854729 0.514918 ) -(0.343279 0.000000 0.939234 ) -(0.686557 0.000000 0.727076 ) -(0.555436 -0.652955 0.514918 ) -(0.792636 -0.326477 0.514918 ) -(0.661515 0.730026 -0.171639 ) -(0.898715 0.403548 -0.171639 ) -(0.489876 0.854729 0.171639 ) -(0.964275 0.201774 0.171639 ) -(0.555436 0.652955 0.514918 ) -(0.792636 0.326477 0.514918 ) -(-0.489876 0.854729 -0.171639 ) -(-0.106079 0.979432 -0.171639 ) -(-0.661515 0.730026 0.171639 ) -(0.106079 0.979432 0.171639 ) -(-0.065560 0.854729 0.514918 ) -(-0.964275 -0.201774 -0.171639 ) -(-0.964275 0.201774 -0.171639 ) -(-0.898715 -0.403548 0.171639 ) -(-0.898715 0.403548 0.171639 ) -(-0.106079 -0.979432 -0.171639 ) -(-0.489876 -0.854729 -0.171639 ) -(0.106079 -0.979432 0.171639 ) -(-0.661515 -0.730026 0.171639 ) -(0.898715 -0.403548 -0.171639 ) -(0.661515 -0.730026 -0.171639 ) -(0.964275 -0.201774 0.171639 ) -(0.489876 -0.854729 0.171639 ) -(0.065560 0.854729 -0.514918 ) -(0.449358 0.730026 -0.514918 ) -(-0.792636 0.326477 -0.514918 ) -(-0.555436 0.652955 -0.514918 ) -(-0.555436 -0.652955 -0.514918 ) -(-0.792636 -0.326477 -0.514918 ) -(0.449358 -0.730026 -0.514918 ) -(0.065560 -0.854729 -0.514918 ) -(0.833155 0.201774 -0.514918 ) -(0.833155 -0.201774 -0.514918 ) -(0.277718 0.201774 -0.939234 ) -(-0.106079 0.326477 -0.939234 ) -(0.555436 0.403548 -0.727076 ) -(-0.212158 0.652955 -0.727076 ) -(-0.343279 0.000000 -0.939234 ) -(-0.686557 0.000000 -0.727076 ) -(-0.106079 -0.326477 -0.939234 ) -(-0.212158 -0.652955 -0.727076 ) -(0.277718 -0.201774 -0.939234 ) -(0.555436 -0.403548 -0.727076 ) -(0.106079 0.326477 0.939234 ) -(0.212158 0.652955 0.727076 ) - ) -) - - + '#((-0.449358 0.730026 0.514918) + (-0.277718 0.201774 0.939234) + (-0.277718 -0.201774 0.939234) + (-0.555436 0.403548 0.727076) + (-0.555436 -0.403548 0.727076) + (-0.833155 0.201774 0.514918) + (-0.833155 -0.201774 0.514918) + ( 0.106079 -0.326477 0.939234) + ( 0.212158 -0.652955 0.727076) + (-0.449358 -0.730026 0.514918) + (-0.065560 -0.854729 0.514918) + ( 0.343279 0.000000 0.939234) + ( 0.686557 0.000000 0.727076) + ( 0.555436 -0.652955 0.514918) + ( 0.792636 -0.326477 0.514918) + ( 0.661515 0.730026 -0.171639) + ( 0.898715 0.403548 -0.171639) + ( 0.489876 0.854729 0.171639) + ( 0.964275 0.201774 0.171639) + ( 0.555436 0.652955 0.514918) + ( 0.792636 0.326477 0.514918) + (-0.489876 0.854729 -0.171639) + (-0.106079 0.979432 -0.171639) + (-0.661515 0.730026 0.171639) + ( 0.106079 0.979432 0.171639) + (-0.065560 0.854729 0.514918) + (-0.964275 -0.201774 -0.171639) + (-0.964275 0.201774 -0.171639) + (-0.898715 -0.403548 0.171639) + (-0.898715 0.403548 0.171639) + (-0.106079 -0.979432 -0.171639) + (-0.489876 -0.854729 -0.171639) + ( 0.106079 -0.979432 0.171639) + (-0.661515 -0.730026 0.171639) + ( 0.898715 -0.403548 -0.171639) + ( 0.661515 -0.730026 -0.171639) + ( 0.964275 -0.201774 0.171639) + ( 0.489876 -0.854729 0.171639) + ( 0.065560 0.854729 -0.514918) + ( 0.449358 0.730026 -0.514918) + (-0.792636 0.326477 -0.514918) + (-0.555436 0.652955 -0.514918) + (-0.555436 -0.652955 -0.514918) + (-0.792636 -0.326477 -0.514918) + ( 0.449358 -0.730026 -0.514918) + ( 0.065560 -0.854729 -0.514918) + ( 0.833155 0.201774 -0.514918) + ( 0.833155 -0.201774 -0.514918) + ( 0.277718 0.201774 -0.939234) + (-0.106079 0.326477 -0.939234) + ( 0.555436 0.403548 -0.727076) + (-0.212158 0.652955 -0.727076) + (-0.343279 0.000000 -0.939234) + (-0.686557 0.000000 -0.727076) + (-0.106079 -0.326477 -0.939234) + (-0.212158 -0.652955 -0.727076) + ( 0.277718 -0.201774 -0.939234) + ( 0.555436 -0.403548 -0.727076) + ( 0.106079 0.326477 0.939234) + ( 0.212158 0.652955 0.727076) + )) + (define (hex-point n size) (apply glVertex3f (map (lambda (x) (* x size)) - (vector-ref bucky-points n))) -) - + (vector-ref bucky-points n)))) (define (hex p1 p2 p3 p4 p5 p6 size) - (norm (vector-ref bucky-points p1) + (norm (vector-ref bucky-points p1) (vector-ref bucky-points p3) - (vector-ref bucky-points p2) + (vector-ref bucky-points p2) 1.0) (glPolygonMode GL_FRONT GL_FILL) (glBegin GL_POLYGON) @@ -135,12 +116,10 @@ (hex-point p2 size) (hex-point p1 size) (glEnd) - (glPolygonMode GL_FRONT GL_FILL) -) - - + (glPolygonMode GL_FRONT GL_FILL)) + (define (pent p1 p2 p3 p4 p5 size) - (norm (vector-ref bucky-points p1) + (norm (vector-ref bucky-points p1) (vector-ref bucky-points p3) (vector-ref bucky-points p2) 1.0) @@ -150,13 +129,11 @@ (hex-point p2 size) (hex-point p4 size) (hex-point p3 size) - (glEnd) -) - - + (glEnd)) + (define (makebucky size) (glEnable GL_NORMALIZE) - + (hex 2 7 8 10 9 4 size) (hex 1 2 4 6 5 3 size) (hex 7 11 12 14 13 8 size) @@ -176,8 +153,8 @@ (hex 40 53 52 49 51 41 size) (hex 44 57 56 54 55 45 size) (hex 46 50 48 56 57 47 size) - (hex 42 55 54 52 53 43 size) - + (hex 42 55 54 52 53 43 size) + (pent 1 58 11 7 2 size) (pent 8 13 37 32 10 size) (pent 4 9 33 28 6 size) @@ -189,373 +166,325 @@ (pent 48 49 52 54 56 size) (pent 15 39 50 46 16 size) (pent 34 47 57 44 35 size) - (pent 26 43 53 40 27 size) - -) - - -; ------------------------------------------------------------------- + (pent 26 43 53 40 27 size) + ) +;; ------------------------------------------------------------------- (define (makebevelcube scale) - (let* - ( (sizex (* 0.6 scale)) - (sizey (* 0.6 scale)) - (sizez (* 0.6 scale)) - (bevel (* 0.15 scale)) - (bsizex (+ sizex bevel)) - (bsizey (+ sizey bevel)) - (bsizez (+ sizez bevel)) - ) - - (glEnable GL_NORMALIZE) - - (glBegin GL_QUADS) - (glNormal3f 0.0 sizey 0.0) - (glVertex3f sizex bsizey sizez) - (glVertex3f sizex bsizey (- sizez)) - (glVertex3f (- sizex) bsizey (- sizez)) - (glVertex3f (- sizex) bsizey sizez) + (define sizex (* 0.6 scale)) + (define sizey (* 0.6 scale)) + (define sizez (* 0.6 scale)) + (define bevel (* 0.15 scale)) + (define bsizex (+ sizex bevel)) + (define bsizey (+ sizey bevel)) + (define bsizez (+ sizez bevel)) - (glNormal3f 0.0 0.0 sizez) - (glVertex3f sizex sizey bsizez) - (glVertex3f (- sizex) sizey bsizez) - (glVertex3f (- sizex) (- sizey) bsizez) - (glVertex3f sizex (- sizey) bsizez) + (glEnable GL_NORMALIZE) - (glNormal3f 0.0 0.0 (- sizez)) - (glVertex3f (- sizex) (- sizey) (- bsizez)) - (glVertex3f (- sizex) sizey (- bsizez)) - (glVertex3f sizex sizey (- bsizez)) - (glVertex3f sizex (- sizey) (- bsizez)) + (glBegin GL_QUADS) + (glNormal3f 0.0 sizey 0.0) + (glVertex3f sizex bsizey sizez) + (glVertex3f sizex bsizey (- sizez)) + (glVertex3f (- sizex) bsizey (- sizez)) + (glVertex3f (- sizex) bsizey sizez) - (glNormal3f sizex 0.0 0.0) - (glVertex3f bsizex sizey sizez) - (glVertex3f bsizex (- sizey) sizez) - (glVertex3f bsizex (- sizey) (- sizez)) - (glVertex3f bsizex sizey (- sizez)) + (glNormal3f 0.0 0.0 sizez) + (glVertex3f sizex sizey bsizez) + (glVertex3f (- sizex) sizey bsizez) + (glVertex3f (- sizex) (- sizey) bsizez) + (glVertex3f sizex (- sizey) bsizez) - (glNormal3f (- sizex) 0.0 0.0) - (glVertex3f (- bsizex) (- sizey) (- sizez)) - (glVertex3f (- bsizex) (- sizey) sizez) - (glVertex3f (- bsizex) sizey sizez) - (glVertex3f (- bsizex) sizey (- sizez)) + (glNormal3f 0.0 0.0 (- sizez)) + (glVertex3f (- sizex) (- sizey) (- bsizez)) + (glVertex3f (- sizex) sizey (- bsizez)) + (glVertex3f sizex sizey (- bsizez)) + (glVertex3f sizex (- sizey) (- bsizez)) - (glNormal3f 0.0 (- sizey) 0.0); - (glVertex3f (- sizex) (- bsizey) (- sizez)); - (glVertex3f sizex (- bsizey) (- sizez)); - (glVertex3f sizex (- bsizey) sizez); - (glVertex3f (- sizex) (- bsizey) sizez); + (glNormal3f sizex 0.0 0.0) + (glVertex3f bsizex sizey sizez) + (glVertex3f bsizex (- sizey) sizez) + (glVertex3f bsizex (- sizey) (- sizez)) + (glVertex3f bsizex sizey (- sizez)) -; setmaterial(blue); + (glNormal3f (- sizex) 0.0 0.0) + (glVertex3f (- bsizex) (- sizey) (- sizez)) + (glVertex3f (- bsizex) (- sizey) sizez) + (glVertex3f (- bsizex) sizey sizez) + (glVertex3f (- bsizex) sizey (- sizez)) - (glNormal3f 0.0 sizey sizez); - (glVertex3f (- sizex) bsizey sizez); - (glVertex3f (- sizex) sizey bsizez); - (glVertex3f sizex sizey bsizez); - (glVertex3f sizex bsizey sizez); + (glNormal3f 0.0 (- sizey) 0.0) + (glVertex3f (- sizex) (- bsizey) (- sizez)) + (glVertex3f sizex (- bsizey) (- sizez)) + (glVertex3f sizex (- bsizey) sizez) + (glVertex3f (- sizex) (- bsizey) sizez) - (glNormal3f sizex 0.0 sizez); - (glVertex3f bsizex sizey sizez); - (glVertex3f sizex sizey bsizez); - (glVertex3f sizex (- sizey) bsizez); - (glVertex3f bsizex (- sizey) sizez); + ;; setmaterial(blue) - (glNormal3f sizex sizey 0.0); - (glVertex3f bsizex sizey (- sizez)); - (glVertex3f sizex bsizey (- sizez)); - (glVertex3f sizex bsizey sizez); - (glVertex3f bsizex sizey sizez); + (glNormal3f 0.0 sizey sizez) + (glVertex3f (- sizex) bsizey sizez) + (glVertex3f (- sizex) sizey bsizez) + (glVertex3f sizex sizey bsizez) + (glVertex3f sizex bsizey sizez) - (glNormal3f 0.0 (- sizey) (- sizez)); - (glVertex3f (- sizex) (- bsizey) (- sizez)); - (glVertex3f (- sizex) (- sizey) (- bsizez)); - (glVertex3f sizex (- sizey) (- bsizez)); - (glVertex3f sizex (- bsizey) (- sizez)); + (glNormal3f sizex 0.0 sizez) + (glVertex3f bsizex sizey sizez) + (glVertex3f sizex sizey bsizez) + (glVertex3f sizex (- sizey) bsizez) + (glVertex3f bsizex (- sizey) sizez) - (glNormal3f (- sizex) 0.0 (- sizez)); - (glVertex3f (- bsizex) sizey (- sizez)); - (glVertex3f (- sizex) sizey (- bsizez)); - (glVertex3f (- sizex) (- sizey) (- bsizez)); - (glVertex3f (- bsizex) (- sizey) (- sizez)); + (glNormal3f sizex sizey 0.0) + (glVertex3f bsizex sizey (- sizez)) + (glVertex3f sizex bsizey (- sizez)) + (glVertex3f sizex bsizey sizez) + (glVertex3f bsizex sizey sizez) - (glNormal3f (- sizex) (- sizey) 0.0); - (glVertex3f (- bsizex) (- sizey) (- sizez)); - (glVertex3f (- sizex) (- bsizey) (- sizez)); - (glVertex3f (- sizex) (- bsizey) sizez); - (glVertex3f (- bsizex) (- sizey) sizez); + (glNormal3f 0.0 (- sizey) (- sizez)) + (glVertex3f (- sizex) (- bsizey) (- sizez)) + (glVertex3f (- sizex) (- sizey) (- bsizez)) + (glVertex3f sizex (- sizey) (- bsizez)) + (glVertex3f sizex (- bsizey) (- sizez)) - (glNormal3f 0.0 (- sizey) sizez); - (glVertex3f sizex (- bsizey) sizez); - (glVertex3f sizex (- sizey) bsizez); - (glVertex3f (- sizex) (- sizey) bsizez); - (glVertex3f (- sizex) (- bsizey) sizez); + (glNormal3f (- sizex) 0.0 (- sizez)) + (glVertex3f (- bsizex) sizey (- sizez)) + (glVertex3f (- sizex) sizey (- bsizez)) + (glVertex3f (- sizex) (- sizey) (- bsizez)) + (glVertex3f (- bsizex) (- sizey) (- sizez)) - (glNormal3f 0.0 sizey (- sizez)); - (glVertex3f (- sizex) sizey (- bsizez)); - (glVertex3f (- sizex) bsizey (- sizez)); - (glVertex3f sizex bsizey (- sizez)); - (glVertex3f sizex sizey (- bsizez)); + (glNormal3f (- sizex) (- sizey) 0.0) + (glVertex3f (- bsizex) (- sizey) (- sizez)) + (glVertex3f (- sizex) (- bsizey) (- sizez)) + (glVertex3f (- sizex) (- bsizey) sizez) + (glVertex3f (- bsizex) (- sizey) sizez) - (glNormal3f (- sizex) 0.0 sizez); - (glVertex3f (- bsizex) (- sizey) sizez); - (glVertex3f (- sizex) (- sizey) bsizez); - (glVertex3f (- sizex) sizey bsizez); - (glVertex3f (- bsizex) sizey sizez); + (glNormal3f 0.0 (- sizey) sizez) + (glVertex3f sizex (- bsizey) sizez) + (glVertex3f sizex (- sizey) bsizez) + (glVertex3f (- sizex) (- sizey) bsizez) + (glVertex3f (- sizex) (- bsizey) sizez) - (glNormal3f sizex 0.0 (- sizez)); - (glVertex3f sizex sizey (- bsizez)); - (glVertex3f bsizex sizey (- sizez)); - (glVertex3f bsizex (- sizey) (- sizez)); - (glVertex3f sizex (- sizey) (- bsizez)); + (glNormal3f 0.0 sizey (- sizez)) + (glVertex3f (- sizex) sizey (- bsizez)) + (glVertex3f (- sizex) bsizey (- sizez)) + (glVertex3f sizex bsizey (- sizez)) + (glVertex3f sizex sizey (- bsizez)) - (glNormal3f (- sizex) sizey 0.0); - (glVertex3f (- bsizex) sizey sizez); - (glVertex3f (- sizex) bsizey sizez); - (glVertex3f (- sizex) bsizey (- sizez)); - (glVertex3f (- bsizex) sizey (- sizez)); + (glNormal3f (- sizex) 0.0 sizez) + (glVertex3f (- bsizex) (- sizey) sizez) + (glVertex3f (- sizex) (- sizey) bsizez) + (glVertex3f (- sizex) sizey bsizez) + (glVertex3f (- bsizex) sizey sizez) - (glNormal3f sizex (- sizey) 0.0); - (glVertex3f sizex (- bsizey) (- sizez)); - (glVertex3f bsizex (- sizey) (- sizez)); - (glVertex3f bsizex (- sizey) sizez); - (glVertex3f sizex (- bsizey) sizez); + (glNormal3f sizex 0.0 (- sizez)) + (glVertex3f sizex sizey (- bsizez)) + (glVertex3f bsizex sizey (- sizez)) + (glVertex3f bsizex (- sizey) (- sizez)) + (glVertex3f sizex (- sizey) (- bsizez)) - (glEnd); + (glNormal3f (- sizex) sizey 0.0) + (glVertex3f (- bsizex) sizey sizez) + (glVertex3f (- sizex) bsizey sizez) + (glVertex3f (- sizex) bsizey (- sizez)) + (glVertex3f (- bsizex) sizey (- sizez)) -; setmaterial(red); - (glBegin GL_TRIANGLES); + (glNormal3f sizex (- sizey) 0.0) + (glVertex3f sizex (- bsizey) (- sizez)) + (glVertex3f bsizex (- sizey) (- sizez)) + (glVertex3f bsizex (- sizey) sizez) + (glVertex3f sizex (- bsizey) sizez) - (glNormal3f sizex sizey sizez); - (glVertex3f bsizex sizey sizez); - (glVertex3f sizex bsizey sizez); - (glVertex3f sizex sizey bsizez); + (glEnd) - (glNormal3f (- sizex) sizey sizez); - (glVertex3f (- sizex) bsizey sizez); - (glVertex3f (- bsizex) sizey sizez); - (glVertex3f (- sizex) sizey bsizez); + ;; setmaterial(red) + (glBegin GL_TRIANGLES) - (glNormal3f (- sizex) (- sizey) sizez); - (glVertex3f (- bsizex) (- sizey) sizez); - (glVertex3f (- sizex) (- bsizey) sizez); - (glVertex3f (- sizex) (- sizey) bsizez); + (glNormal3f sizex sizey sizez) + (glVertex3f bsizex sizey sizez) + (glVertex3f sizex bsizey sizez) + (glVertex3f sizex sizey bsizez) - (glNormal3f sizex (- sizey) sizez); - (glVertex3f sizex (- bsizey) sizez); - (glVertex3f bsizex (- sizey) sizez); - (glVertex3f sizex (- sizey) bsizez); + (glNormal3f (- sizex) sizey sizez) + (glVertex3f (- sizex) bsizey sizez) + (glVertex3f (- bsizex) sizey sizez) + (glVertex3f (- sizex) sizey bsizez) + (glNormal3f (- sizex) (- sizey) sizez) + (glVertex3f (- bsizex) (- sizey) sizez) + (glVertex3f (- sizex) (- bsizey) sizez) + (glVertex3f (- sizex) (- sizey) bsizez) - (glNormal3f (- sizex) (- sizey) (- sizez)); - (glVertex3f (- sizex) (- sizey) (- bsizez)); - (glVertex3f (- sizex) (- bsizey) (- sizez)); - (glVertex3f (- bsizex) (- sizey) (- sizez)); + (glNormal3f sizex (- sizey) sizez) + (glVertex3f sizex (- bsizey) sizez) + (glVertex3f bsizex (- sizey) sizez) + (glVertex3f sizex (- sizey) bsizez) - (glNormal3f sizex (- sizey) (- sizez)); - (glVertex3f sizex (- sizey) (- bsizez)); - (glVertex3f bsizex (- sizey) (- sizez)); - (glVertex3f sizex (- bsizey) (- sizez)); + (glNormal3f (- sizex) (- sizey) (- sizez)) + (glVertex3f (- sizex) (- sizey) (- bsizez)) + (glVertex3f (- sizex) (- bsizey) (- sizez)) + (glVertex3f (- bsizex) (- sizey) (- sizez)) - (glNormal3f sizex sizey (- sizez)); - (glVertex3f sizex sizey (- bsizez)); - (glVertex3f sizex bsizey (- sizez)); - (glVertex3f bsizex sizey (- sizez)); + (glNormal3f sizex (- sizey) (- sizez)) + (glVertex3f sizex (- sizey) (- bsizez)) + (glVertex3f bsizex (- sizey) (- sizez)) + (glVertex3f sizex (- bsizey) (- sizez)) - (glNormal3f (- sizex) sizey (- sizez)); - (glVertex3f (- sizex) sizey (- bsizez)); - (glVertex3f (- bsizex) sizey (- sizez)); - (glVertex3f (- sizex) bsizey (- sizez)); + (glNormal3f sizex sizey (- sizez)) + (glVertex3f sizex sizey (- bsizez)) + (glVertex3f sizex bsizey (- sizez)) + (glVertex3f bsizex sizey (- sizez)) - (glEnd); - ) -) + (glNormal3f (- sizex) sizey (- sizez)) + (glVertex3f (- sizex) sizey (- bsizez)) + (glVertex3f (- bsizex) sizey (- sizez)) + (glVertex3f (- sizex) bsizey (- sizez)) + (glEnd)) -; ------------------------------------------------------------------- +;; ------------------------------------------------------------------- (define (makecylinder size) - (let* - ( (csqueeze 0.8) - (csides 12) - (x (make-vector csides 0.0)) - (z (make-vector csides 0.0)) - (a #f) - (cur #f) (prev #f) - ) - - (do ((i 0 (+ i 1))) ((= i csides)) - (set! a (/ (* i 3.1415928 2.0) csides)) - (vector-set! x i (* (cos a) size csqueeze)) - (vector-set! z i (* (sin a) size csqueeze)) - ) - - (glEnable GL_NORMALIZE) - ; bottom - (glNormal3f 0.0 -1.0 0.0) - (glBegin GL_POLYGON) - (do ((i 0 (+ i 1))) ((= i csides)) - (glVertex3f (vector-ref x i) - (- size) - (vector-ref z i)) - ) - (glEnd) - ; top - (glNormal3f 0.0 1.0 0.0) - (glBegin GL_POLYGON) - (do ((i 0 (+ i 1))) ((= i csides)) - (glVertex3f (vector-ref x (- csides 1 i)) - (- size) - (vector-ref z (- csides 1 i))) - ) - (glEnd) - ;side - (glBegin GL_QUAD_STRIP) - (do ((i 0 (+ i 1))) ((= i (+ csides 1))) - (set! cur (if (< i csides) i (- i csides))) - (when (> i 0) - (glNormal3f (/ (+ (vector-ref x cur) - (vector-ref x prev)) 2.0) - 0.0 - (/ (+ (vector-ref z cur) - (vector-ref z prev)) 2.0)) - ) - (glVertex3f (vector-ref x cur) - (- size) - (vector-ref z cur)) - (glVertex3f (vector-ref x cur) - size - (vector-ref z cur)) - (set! prev cur) - ) - (glEnd) - ) -) + (define csqueeze 0.8) + (define csides 12) + (define x (make-vector csides 0.0)) + (define z (make-vector csides 0.0)) + (define a #f) + (define cur #f) + (define prev #f) -; ------------------------------------------------------------------- + (for ([i (in-range csides)]) + (set! a (/ (* i 3.1415928 2.0) csides)) + (vector-set! x i (* (cos a) size csqueeze)) + (vector-set! z i (* (sin a) size csqueeze))) + + (glEnable GL_NORMALIZE) + ;; bottom + (glNormal3f 0.0 -1.0 0.0) + (glBegin GL_POLYGON) + (for ([i (in-range csides)]) + (glVertex3f (vector-ref x i) + (- size) + (vector-ref z i))) + (glEnd) + ;; top + (glNormal3f 0.0 1.0 0.0) + (glBegin GL_POLYGON) + (for ([i (in-range csides)]) + (glVertex3f (vector-ref x (- csides 1 i)) + (- size) + (vector-ref z (- csides 1 i)))) + (glEnd) + ;; side + (glBegin GL_QUAD_STRIP) + (for ([i (in-range (+ csides 1))]) + (set! cur (if (< i csides) i (- i csides))) + (when (> i 0) + (glNormal3f (/ (+ (vector-ref x cur) + (vector-ref x prev)) 2.0) + 0.0 + (/ (+ (vector-ref z cur) + (vector-ref z prev)) 2.0))) + (glVertex3f (vector-ref x cur) (- size) (vector-ref z cur)) + (glVertex3f (vector-ref x cur) size (vector-ref z cur)) + (set! prev cur)) + (glEnd)) + +;; ------------------------------------------------------------------- (define (makeuvsphere size) - (let* - ( (usides 15) - (vsides 9) - (x (make-vector usides 0.0)) - (z (make-vector usides 0.0)) - (a #f) (t #f) - (c1 #f) (s1 #f) (c2 #f) (s2 #f) - ) + (define usides 15) + (define vsides 9) + (define x (make-vector usides 0.0)) + (define z (make-vector usides 0.0)) + (define a #f) + (define t #f) + (define c1 #f) + (define s1 #f) + (define c2 #f) + (define s2 #f) - (do ((i 0 (+ i 1))) ((= i usides)) - (set! a (/ (* i 3.1415928 2.0) usides)) - (vector-set! x i (* (cos a) size)) - (vector-set! z i (* (sin a) size)) - ) - - (glEnable GL_NORMALIZE) - - (do ((i 0 (+ i 1))) ((= i vsides)) - (set! a (/ (* i 3.1415927) vsides)) - (set! c1 (cos a)) - (set! s1 (sin a)) - (set! a (/ (* (+ i 1) 3.1415927) vsides)) - (set! c2 (cos a)) - (set! s2 (sin a)) - - (glBegin GL_QUAD_STRIP) - (do ((j 0 (+ j 1))) ((= j (+ usides 1))) - (set! t (if (< j usides) j (- j usides))) - (when (not (= j 0)) - (let* - ( (c #f) (s #f) ) - (set! a (/ (* (+ i 0.5) 3.1415927) vsides)) - (set! c (cos a)) - (set! s (sin a)) - (set! a (/ (* (- j 0.5) 3.1415927 2.0) usides)) - (glNormal3f (* (cos a) s) - c - (* (sin a) s)) - ) - ) - (glVertex3f (* (vector-ref x t) s2) - (* c2 size) - (* (vector-ref z t) s2)) - (glVertex3f (* (vector-ref x t) s1) - (* c1 size) - (* (vector-ref z t) s1)) - ) - (glEnd) - - ) - + (for ([i (in-range usides)]) + (set! a (/ (* i 3.1415928 2.0) usides)) + (vector-set! x i (* (cos a) size)) + (vector-set! z i (* (sin a) size))) - ) -) - - -; ------------------------------------------------------------------- + (glEnable GL_NORMALIZE) + + (for ([i (in-range vsides)]) + (set! a (/ (* i 3.1415927) vsides)) + (set! c1 (cos a)) + (set! s1 (sin a)) + (set! a (/ (* (+ i 1) 3.1415927) vsides)) + (set! c2 (cos a)) + (set! s2 (sin a)) + + (glBegin GL_QUAD_STRIP) + (for ([j (in-range (+ usides 1))]) + (set! t (if (< j usides) j (- j usides))) + (unless (= j 0) + (let* ((c #f) (s #f)) + (set! a (/ (* (+ i 0.5) 3.1415927) vsides)) + (set! c (cos a)) + (set! s (sin a)) + (set! a (/ (* (- j 0.5) 3.1415927 2.0) usides)) + (glNormal3f (* (cos a) s) c (* (sin a) s)))) + (glVertex3f (* (vector-ref x t) s2) + (* c2 size) + (* (vector-ref z t) s2)) + (glVertex3f (* (vector-ref x t) s1) + (* c1 size) + (* (vector-ref z t) s1))) + (glEnd))) + +;; ------------------------------------------------------------------- (define (makediamond size) - (let* - ( (dsides 9) - (x (make-vector dsides 0.0)) - (z (make-vector dsides 0.0)) - (a #f) (p1 #f) (p2 #f) - (c #f) (d #f) (h #f) (s #f) (j #f) (o #f) - ) - - (do ((i 0 (+ i 1))) ((= i dsides)) + (let* ((dsides 9) + (x (make-vector dsides 0.0)) + (z (make-vector dsides 0.0)) + (a #f) (p1 #f) (p2 #f) + (c #f) (d #f) (h #f) (s #f) (j #f) (o #f)) + + (for ([i (in-range dsides)]) (set! a (/ (* i 3.1415928 2.0) dsides)) (vector-set! x i (* (cos a) size)) - (vector-set! z i (* (sin a) size)) - ) - + (vector-set! z i (* (sin a) size))) + (glEnable GL_NORMALIZE) - + (set! p2 (* size 0.5)) - (do ((t 0 (+ t 1))) ((= t 2)) - (if (remainder t 2) - (set! p1 (- size)) - (set! p1 size) - ) - + (for ([t (in-range 2)]) + (set! p1 (if (remainder t 2) (- size) size)) + (glBegin GL_TRIANGLE_FAN) (glVertex3f 0.0 p1 0.0) (set! d (if (= t 0) (- size p2) (+ size p2))) (set! h (sqrt (+ (* size size) (* d d)))) (set! c (if (= t 0) (/ size h) (/ (- size) h))) (set! s (/ d h)) - (do ((i 0 (+ i 1))) ((= i (+ dsides 1))) + (for ([i (in-range (+ dsides 1))]) (set! j (if (< i dsides) i (- i dsides))) - (when (= t 0) - (set! j (- dsides 1 j)) - ) + (when (= t 0) (set! j (- dsides 1 j))) (when (> i 0) (glNormal3f (* (/ (+ (vector-ref x j) (vector-ref x o)) 2.0) s) (* size c) (* (/ (+ (vector-ref z j) - (vector-ref z o)) 2.0) s) ) - ) + (vector-ref z o)) 2.0) s))) (glVertex3f (vector-ref x j) p2 (vector-ref z j)) - (set! o j) - ) - (glEnd) - ) - - ) -) - + (set! o j)) + (glEnd)))) (define (makedisc size) - (let ([q (gl-new-quadric)]) - (gl-quadric-draw-style q 'fill) - (gl-quadric-normals q 'smooth) - (gl-sphere q size 25 25))) + (define q (gl-new-quadric)) + (gl-quadric-draw-style q 'fill) + (gl-quadric-normals q 'smooth) + (gl-sphere q size 25 25)) -; ------------------------------------------------------------------- +;; ------------------------------------------------------------------- (define (makepyramid size) (glEnable GL_NORMALIZE) - + (glBegin GL_QUADS) (glNormal3f 0.0 (- size) 0.0) (glVertex3f size (- size) size) @@ -563,7 +492,7 @@ (glVertex3f (- size) (- size) (- size)) (glVertex3f size (- size) (- size)) (glEnd) - + (glBegin GL_TRIANGLE_FAN) (glVertex3f 0.0 size 0.0) @@ -576,107 +505,99 @@ (glVertex3f (- size) (- size) size) (glNormal3f 0.0 -1.0 2.0) (glVertex3f size (- size) size) - (glEnd) + (glEnd)) -) - -; ------------------------------------------------------------------- +;; ------------------------------------------------------------------- (define (makeicosahedron scale) - (let* - ( (coord #( #(-0.525731112119133606 0.0 0.850650808352039932) - #( 0.525731112119133606 0.0 0.850650808352039932) - #(-0.525731112119133606 0.0 -0.850650808352039932) - #( 0.525731112119133606 0.0 -0.850650808352039932) - - #(0.0 0.850650808352039932 0.525731112119133606) - #(0.0 0.850650808352039932 -0.525731112119133606) - #(0.0 -0.850650808352039932 0.525731112119133606) - #(0.0 -0.850650808352039932 -0.525731112119133606) + (define coord + #(#(-0.525731112119133606 0.0 0.850650808352039932) + #( 0.525731112119133606 0.0 0.850650808352039932) + #(-0.525731112119133606 0.0 -0.850650808352039932) + #( 0.525731112119133606 0.0 -0.850650808352039932) - #( 0.850650808352039932 0.525731112119133606 0.0) - #(-0.850650808352039932 0.525731112119133606 0.0) - #( 0.850650808352039932 -0.525731112119133606 0.0) - #(-0.850650808352039932 -0.525731112119133606 0.0) ) ) - (indices #( #(1 4 0) #(4 9 0) #(4 5 9) #(8 5 4) #(1 8 4) - #(1 10 8) #(10 3 8) #(8 3 5) #(3 2 5) #(3 7 2) - #(3 10 7) #(10 6 7) #(6 11 7) #(6 0 11) #(6 1 0) - #(10 1 6) #(11 0 9) #(2 11 9) #(5 2 9) #(11 2 7))) - (triang #f) - (p0 #f) (p1 #f) (p2 #f) - ) - (glEnable GL_NORMALIZE) - (glBegin GL_TRIANGLES) - (do ((i 0 (+ i 1))) ((= i 20)) - (set! triang (vector-ref indices i)) - (set! p0 (vector-ref coord (vector-ref triang 0))) - (set! p1 (vector-ref coord (vector-ref triang 1))) - (set! p2 (vector-ref coord (vector-ref triang 2))) - (norm (vector->list p0) - (vector->list p1) - (vector->list p2) - 1.0) - (glVertex3f (* (vector-ref p0 0) scale) - (* (vector-ref p0 1) scale) - (* (vector-ref p0 2) scale) ) - (glVertex3f (* (vector-ref p1 0) scale) - (* (vector-ref p1 1) scale) - (* (vector-ref p1 2) scale) ) - (glVertex3f (* (vector-ref p2 0) scale) - (* (vector-ref p2 1) scale) - (* (vector-ref p2 2) scale) ) - ) - (glEnd) - ) -) + #(0.0 0.850650808352039932 0.525731112119133606) + #(0.0 0.850650808352039932 -0.525731112119133606) + #(0.0 -0.850650808352039932 0.525731112119133606) + #(0.0 -0.850650808352039932 -0.525731112119133606) -; ------------------------------------------------------------------- + #( 0.850650808352039932 0.525731112119133606 0.0) + #(-0.850650808352039932 0.525731112119133606 0.0) + #( 0.850650808352039932 -0.525731112119133606 0.0) + #(-0.850650808352039932 -0.525731112119133606 0.0))) + (define indices + #( #(1 4 0) #(4 9 0) #(4 5 9) #(8 5 4) #(1 8 4) + #(1 10 8) #(10 3 8) #(8 3 5) #(3 2 5) #(3 7 2) + #(3 10 7) #(10 6 7) #(6 11 7) #(6 0 11) #(6 1 0) + #(10 1 6) #(11 0 9) #(2 11 9) #(5 2 9) #(11 2 7))) + (define triang #f) + (define p0 #f) + (define p1 #f) + (define p2 #f) + (glEnable GL_NORMALIZE) + (glBegin GL_TRIANGLES) + (for ([i (in-range 20)]) + (set! triang (vector-ref indices i)) + (set! p0 (vector-ref coord (vector-ref triang 0))) + (set! p1 (vector-ref coord (vector-ref triang 1))) + (set! p2 (vector-ref coord (vector-ref triang 2))) + (norm (vector->list p0) + (vector->list p1) + (vector->list p2) + 1.0) + (glVertex3f (* (vector-ref p0 0) scale) + (* (vector-ref p0 1) scale) + (* (vector-ref p0 2) scale)) + (glVertex3f (* (vector-ref p1 0) scale) + (* (vector-ref p1 1) scale) + (* (vector-ref p1 2) scale)) + (glVertex3f (* (vector-ref p2 0) scale) + (* (vector-ref p2 1) scale) + (* (vector-ref p2 2) scale))) + (glEnd)) + +;; ------------------------------------------------------------------- (define (makespiky scale) - (let* - ( (spikes 12) - (spikez 0.5) - (spikein 0.7) - (x1 (make-vector spikes 0.0)) - (y1 (make-vector spikes 0.0)) - (x2 (make-vector spikes 0.0)) - (y2 (make-vector spikes 0.0)) - (p0 (make-vector 3 0.0)) - (p1 (make-vector 3 0.0)) - (p2 (make-vector 3 0.0)) - (b (/ (* 3.1415927 2.0) spikes)) - (b2 (/ b 2.0)) - (a #f) (j #f) - ) - + (let* ([spikes 12] + [spikez 0.5] + [spikein 0.7] + [x1 (make-vector spikes 0.0)] + [y1 (make-vector spikes 0.0)] + [x2 (make-vector spikes 0.0)] + [y2 (make-vector spikes 0.0)] + [p0 (make-vector 3 0.0)] + [p1 (make-vector 3 0.0)] + [p2 (make-vector 3 0.0)] + [b (/ (* 3.1415927 2.0) spikes)] + [b2 (/ b 2.0)] + [a #f] [j #f]) + (glEnable GL_NORMALIZE) - (do ((i 0 (+ i 1))) ((= i spikes)) + (for ([i (in-range spikes)]) (set! a (* i b)) (vector-set! x1 i (* (cos a) scale spikein)) (vector-set! y1 i (* (sin a) scale spikein)) (vector-set! x2 i (* (cos (+ b2 a)) scale)) - (vector-set! y2 i (* (sin (+ b2 a)) scale)) - ) + (vector-set! y2 i (* (sin (+ b2 a)) scale))) - ; first side + ;; first side (glBegin GL_TRIANGLE_FAN) - + (vector-set! p0 0 0.0) (vector-set! p0 1 0.0) (vector-set! p0 2 (* spikez scale)) (glVertex3fv (vector->gl-float-vector p0)) - + (vector-set! p1 0 (vector-ref x1 0)) (vector-set! p1 1 (vector-ref y1 0)) (vector-set! p1 2 0.0) (glVertex3fv (vector->gl-float-vector p1)) - - (do ((i 0 (+ i 1))) ((= i spikes)) + + (for ([i (in-range spikes)]) (set! j (+ i 1)) - (when (>= j spikes) - (set! j (- j spikes)) - ) - + (when (>= j spikes) (set! j (- j spikes))) + (vector-set! p2 0 (vector-ref x2 i)) (vector-set! p2 1 (vector-ref y2 i)) (vector-set! p2 2 0.0) @@ -693,30 +614,27 @@ (vector->list p2) (vector->list p1) 1.0) - (glVertex3fv (vector->gl-float-vector p1)) - ) - + (glVertex3fv (vector->gl-float-vector p1))) + (glEnd) - ; second side + ;; second side (glBegin GL_TRIANGLE_FAN) - + (vector-set! p0 0 0.0) (vector-set! p0 1 0.0) (vector-set! p0 2 (* (- spikez) scale)) (glVertex3fv (vector->gl-float-vector p0)) - + (vector-set! p1 0 (vector-ref x1 0)) (vector-set! p1 1 (vector-ref y1 0)) (vector-set! p1 2 0.0) (glVertex3fv (vector->gl-float-vector p1)) - - (do ((i 0 (+ i 1))) ((= i spikes)) + + (for ([i (in-range spikes)]) (set! j (+ i 1)) - (when (>= j spikes) - (set! j (- j spikes)) - ) - + (when (>= j spikes) (set! j (- j spikes))) + (vector-set! p2 0 (vector-ref x2 i)) (vector-set! p2 1 (vector-ref y2 i)) (vector-set! p2 2 0.0) @@ -733,16 +651,8 @@ (vector->list p2) (vector->list p1) -1.0) - (glVertex3fv (vector->gl-float-vector p1)) - ) - - (glEnd) - - ) -) + (glVertex3fv (vector->gl-float-vector p1))) + (glEnd))) -; ------------------------------------------------------------------- - -) ; end of module - +;; ------------------------------------------------------------------- diff --git a/collects/games/jewel/text.rkt b/collects/games/jewel/text.rkt index a6de9d888f..72245d8865 100644 --- a/collects/games/jewel/text.rkt +++ b/collects/games/jewel/text.rkt @@ -1,186 +1,157 @@ -(module text racket +#lang racket/base - (require racket - racket/class - sgl/gl - sgl/gl-vectors - ) - - (provide string-init string-draw) - - ; HERSHEY fonts - (define hershey-fonts - '#( (#\A "MWRMNV RRMVV RPSTS") - (#\B "MWOMOV ROMSMUNUPSQ ROQSQURUUSVOV") - (#\C "MXVNTMRMPNOPOSPURVTVVU") - (#\D "MWOMOV ROMRMTNUPUSTURVOV") - (#\E "MWOMOV ROMUM ROQSQ ROVUV") - (#\F "MVOMOV ROMUM ROQSQ") - (#\G "MXVNTMRMPNOPOSPURVTVVUVR RSRVR") - (#\H "MWOMOV RUMUV ROQUQ") - (#\I "MTRMRV") ; modified - (#\J "NUSMSTRVPVOTOS") - (#\K "MWOMOV RUMOS RQQUV") - (#\L "MVOMOV ROVUV") - (#\M "LXNMNV RNMRV RVMRV RVMVV") - (#\N "MWOMOV ROMUV RUMUV") - (#\O "MXRMPNOPOSPURVSVUUVSVPUNSMRM") - (#\P "MWOMOV ROMSMUNUQSROR") - (#\Q "MXRMPNOPOSPURVSVUUVSVPUNSMRM RSTVW") - (#\R "MWOMOV ROMSMUNUQSROR RRRUV") - (#\S "MWUNSMQMONOOPPTRUSUUSVQVOU") - (#\T "MWRMRV RNMVM") - (#\U "MXOMOSPURVSVUUVSVM") - (#\V "MWNMRV RVMRV") - (#\W "LXNMPV RRMPV RRMTV RVMTV") - (#\X "MWOMUV RUMOV") - (#\Y "MWNMRQRV RVMRQ") - (#\Z "MWUMOV ROMUM ROVUV") - (#\space "LX") - ; numbers - (#\0 "MWRMPNOPOSPURVTUUSUPTNRM") - (#\1 "MWPORMRV") - (#\2 "MWONQMSMUNUPTROVUV") - (#\3 "MWONQMSMUNUPSQ RRQSQURUUSVQVOU") - (#\4 "MWSMSV RSMNSVS") - (#\5 "MWPMOQQPRPTQUSTURVQVOU RPMTM") - (#\6 "MWTMRMPNOPOSPURVTUUSTQRPPQOS") - (#\7 "MWUMQV ROMUM") - (#\8 "MWQMONOPQQSQUPUNSMQM RQQOROUQVSVUUURSQ") - (#\9 "MWUPTRRSPROPPNRMTNUPUSTURVPV") - ; signs - (#\- "LXNRVR") - (#\+ "LXRNRV RNRVR") - ; !!!!! this must exist !!!!! - (#\* "MWRORU ROPUT RUPOT") +(require racket/class sgl/gl sgl/gl-vectors) - ) - ) - - - ; font database is a hash table - (define font-db (make-hash)) - (define font-gen #f) - (define font-scale #f) - - (define (real->int val) - (inexact->exact (round val)) - ) - - ; interpret a hershey font - (define (interpret-hershey str scale) - (let* - ( (nc (/ (string-length str) 2)) - (cx #f) (cy #f) (x #f) (y #f) - (left (char->integer (string-ref str 0))) - (right (char->integer (string-ref str 1))) - (rchar (char->integer #\R)) - ) - (set! left (- left rchar)) - (set! right (- right rchar)) - - (glBegin GL_LINE_STRIP) - (do ((i 1 (+ i 1))) ((= i nc)) - (set! cx (string-ref str (+ (* i 2) 0))) - (set! cy (string-ref str (+ (* i 2) 1))) - (if (and (char=? cx #\space) - (char=? cy #\R)) - (begin - (glEnd) - (glBegin GL_LINE_STRIP) - ) - (begin - (set! x (* (- (char->integer cx) rchar) scale) ) - (set! y (* (- (char->integer cy) rchar) scale) ) - (glVertex2f x (- y)) - ) - ) - ) - (glEnd) - - ; width of the font - (- right left) - ) - ) +(provide string-init string-draw) - - ; initialise the font database - (define (string-init scale) - (let* - ( (n (vector-length hershey-fonts)) - (elem #f) - (width #f) - ) - - (set! font-scale scale) - (set! font-gen (glGenLists n)) - (glLineWidth 2.0) - - (do ((i 0 (+ i 1))) ((= i n)) - (set! elem (vector-ref hershey-fonts i)) - (glNewList (+ font-gen i) GL_COMPILE) - (set! width (interpret-hershey (cadr elem) scale)) - (glEndList) - - (hash-set! font-db (car elem) (cons i width)) - ) - ) - ) - - ; draw the text - (define (string-draw str) - (let* - ( (n (string-length str)) - (c #f) (e #f) - (star (hash-ref font-db #\*)) - ) - (glPushMatrix) - (glNormal3f 0.0 0.0 1.0) - (do ((i 0 (+ i 1))) ((= i n)) - (set! c (string-ref str i)) - (set! e (hash-ref font-db c (lambda () star) )) - (glCallList (+ font-gen (car e))) - (glTranslatef (* font-scale (cdr e)) 0.0 0.0) - ) - (glPopMatrix) - ) - ) - - - ; ------------------------------------------------------- - ; Testing - - #| - (define *GL_VIEWPORT_WIDTH* #f) - (define *GL_VIEWPORT_HEIGHT* #f) - (define scale 1.5) - (define bit '#(1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1)) - - (define (my-display) - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) - (glOrtho 0 *GL_VIEWPORT_WIDTH* 0 *GL_VIEWPORT_HEIGHT* -1 1) - - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - - (glTranslatef (/ *GL_VIEWPORT_WIDTH* 2) - (/ *GL_VIEWPORT_HEIGHT* 2) - 0.0) - (string-draw "+12" scale) - ; (glRasterPos2i 50 50) - ;(glBitmap 8 8 0.0 0.0 8.0 0.0 (vector->gl-ubyte-vector bit)) - ) - - - (define my-canvas% +;; HERSHEY fonts +(define hershey-fonts + '#( (#\A "MWRMNV RRMVV RPSTS") + (#\B "MWOMOV ROMSMUNUPSQ ROQSQURUUSVOV") + (#\C "MXVNTMRMPNOPOSPURVTVVU") + (#\D "MWOMOV ROMRMTNUPUSTURVOV") + (#\E "MWOMOV ROMUM ROQSQ ROVUV") + (#\F "MVOMOV ROMUM ROQSQ") + (#\G "MXVNTMRMPNOPOSPURVTVVUVR RSRVR") + (#\H "MWOMOV RUMUV ROQUQ") + (#\I "MTRMRV") ; modified + (#\J "NUSMSTRVPVOTOS") + (#\K "MWOMOV RUMOS RQQUV") + (#\L "MVOMOV ROVUV") + (#\M "LXNMNV RNMRV RVMRV RVMVV") + (#\N "MWOMOV ROMUV RUMUV") + (#\O "MXRMPNOPOSPURVSVUUVSVPUNSMRM") + (#\P "MWOMOV ROMSMUNUQSROR") + (#\Q "MXRMPNOPOSPURVSVUUVSVPUNSMRM RSTVW") + (#\R "MWOMOV ROMSMUNUQSROR RRRUV") + (#\S "MWUNSMQMONOOPPTRUSUUSVQVOU") + (#\T "MWRMRV RNMVM") + (#\U "MXOMOSPURVSVUUVSVM") + (#\V "MWNMRV RVMRV") + (#\W "LXNMPV RRMPV RRMTV RVMTV") + (#\X "MWOMUV RUMOV") + (#\Y "MWNMRQRV RVMRQ") + (#\Z "MWUMOV ROMUM ROVUV") + (#\space "LX") + ;; numbers + (#\0 "MWRMPNOPOSPURVTUUSUPTNRM") + (#\1 "MWPORMRV") + (#\2 "MWONQMSMUNUPTROVUV") + (#\3 "MWONQMSMUNUPSQ RRQSQURUUSVQVOU") + (#\4 "MWSMSV RSMNSVS") + (#\5 "MWPMOQQPRPTQUSTURVQVOU RPMTM") + (#\6 "MWTMRMPNOPOSPURVTUUSTQRPPQOS") + (#\7 "MWUMQV ROMUM") + (#\8 "MWQMONOPQQSQUPUNSMQM RQQOROUQVSVUUURSQ") + (#\9 "MWUPTRRSPROPPNRMTNUPUSTURVPV") + ;; signs + (#\- "LXNRVR") + (#\+ "LXRNRV RNRVR") + ;; !!!!! this must exist !!!!! + (#\* "MWRORU ROPUT RUPOT") + )) + +;; font database is a hash table +(define font-db (make-hash)) +(define font-gen #f) +(define font-scale #f) + +(define (real->int val) + (inexact->exact (round val))) + +;; interpret a hershey font +(define (interpret-hershey str scale) + (let* ([nc (/ (string-length str) 2)] + [cx #f] [cy #f] [x #f] [y #f] + [left (char->integer (string-ref str 0))] + [right (char->integer (string-ref str 1))] + [rchar (char->integer #\R)]) + (set! left (- left rchar)) + (set! right (- right rchar)) + + (glBegin GL_LINE_STRIP) + (for ([i (in-range 1 nc)]) + (set! cx (string-ref str (+ (* i 2) 0))) + (set! cy (string-ref str (+ (* i 2) 1))) + (if (and (char=? cx #\space) + (char=? cy #\R)) + (begin (glEnd) + (glBegin GL_LINE_STRIP)) + (begin (set! x (* (- (char->integer cx) rchar) scale)) + (set! y (* (- (char->integer cy) rchar) scale)) + (glVertex2f x (- y))))) + (glEnd) + + ;; width of the font + (- right left))) + + +;; initialise the font database +(define (string-init scale) + (let* ([n (vector-length hershey-fonts)] + [elem #f] + [width #f]) + + (set! font-scale scale) + (set! font-gen (glGenLists n)) + (glLineWidth 2.0) + + (for ([i (in-range n)]) + (set! elem (vector-ref hershey-fonts i)) + (glNewList (+ font-gen i) GL_COMPILE) + (set! width (interpret-hershey (cadr elem) scale)) + (glEndList) + + (hash-set! font-db (car elem) (cons i width))))) + +;; draw the text +(define (string-draw str) + (let* ([n (string-length str)] + [c #f] [e #f] + [star (hash-ref font-db #\*)]) + (glPushMatrix) + (glNormal3f 0.0 0.0 1.0) + (for ([i (in-range n)]) + (set! c (string-ref str i)) + (set! e (hash-ref font-db c (lambda () star))) + (glCallList (+ font-gen (car e))) + (glTranslatef (* font-scale (cdr e)) 0.0 0.0)) + (glPopMatrix))) + + +;; ------------------------------------------------------- +;; Testing + +#| +(define *GL_VIEWPORT_WIDTH* #f) +(define *GL_VIEWPORT_HEIGHT* #f) +(define scale 1.5) +(define bit '#(1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1)) + +(define (my-display) + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) + (glOrtho 0 *GL_VIEWPORT_WIDTH* 0 *GL_VIEWPORT_HEIGHT* -1 1) + + (glMatrixMode GL_MODELVIEW) + (glLoadIdentity) + + (glTranslatef (/ *GL_VIEWPORT_WIDTH* 2) + (/ *GL_VIEWPORT_HEIGHT* 2) + 0.0) + (string-draw "+12" scale) + ;; (glRasterPos2i 50 50) + ;; (glBitmap 8 8 0.0 0.0 8.0 0.0 (vector->gl-ubyte-vector bit)) +) + +(define my-canvas% (class* canvas% () (inherit with-gl-context swap-gl-buffers) @@ -192,39 +163,24 @@ (glClear GL_DEPTH_BUFFER_BIT) (my-display) - (swap-gl-buffers) - ) - ) - ) + (swap-gl-buffers)))) (define/override (on-size width height) (with-gl-context (lambda () (set! *GL_VIEWPORT_WIDTH* width) (set! *GL_VIEWPORT_HEIGHT* height) - - (string-init scale) - ) - ) - ) - (super-instantiate () (style '(gl))) - ) - ) + (string-init scale)))) - ; initialise fonts - - (let* - ( (f (make-object frame% "Font test" #f)) - (w (instantiate my-canvas% (f) - (min-width 300) - (min-height 100))) - ) + (super-instantiate () (style '(gl))))) - (send f show #t) - ) - |# - -) ; end of module +;; initialise fonts +(let* ([f (make-object frame% "Font test" #f)] + [w (instantiate my-canvas% (f) + (min-width 300) + (min-height 100))]) + (send f show #t)) +|#