diff --git a/collects/games/doc.txt b/collects/games/doc.txt index 83aa6055bf..8b33b25d9d 100644 --- a/collects/games/doc.txt +++ b/collects/games/doc.txt @@ -24,13 +24,13 @@ or other games installed as sub-collections of the "games" collection - by Matthew - * Crazy 8s : The card game where you try to get rid of all you cards + * Crazy 8s - The card game where you try to get rid of all you cards by matching the top card in the discard pile. Click "Help" in the game for details. - by Matthew - * Blackjack : Standard rules. Click "Help" in the game for specifics. + * Blackjack - Standard rules. Click "Help" in the game for specifics. - by Matthew @@ -79,6 +79,11 @@ or other games installed as sub-collections of the "games" collection - by Scott + * Jewel - Swap the jewels to make 3-in-a-row. + + - by Dave Ashley + and Peter Ivanyi + Implementing new Games ---------------------- diff --git a/collects/games/info.ss b/collects/games/info.ss index 655c970ce7..6ae74b0041 100644 --- a/collects/games/info.ss +++ b/collects/games/info.ss @@ -6,7 +6,8 @@ (define doc-sub-collections (list "cards" "paint-by-numbers" "same" "lights-out" "aces" "spider" "memory" "pousse" "crazy8s" - "gcalc" "parcheesi" "gl-board-game")) + "gcalc" "parcheesi" "gl-board-game" + "jewel")) (define blurb (list "Demos a few small " '(a ((MZSCHEME " diff --git a/collects/games/jewel/array.scm b/collects/games/jewel/array.scm new file mode 100644 index 0000000000..df64d89150 --- /dev/null +++ b/collects/games/jewel/array.scm @@ -0,0 +1,169 @@ +; -*- Scheme -*- + +(module array mzscheme + +(provide array-make array-ref array-set! + array-mult array-mult-vector + array-det array-sub array-inv +) + + +; 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 + ) +) + +; returns an array element +(define (array-ref m i j) + (vector-ref (vector-ref m i) j) +) + +; sets an array element +(define (array-set! m i j val) + (let* + ( (vect (vector-ref m i)) ) + (vector-set! vect j val) + ) +) + +; 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 + ) +) + +; 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 + ) +) + +; 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)) + (if (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 + ) + ) + ) +) + +; 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)) + (if (not (= i in)) + (begin + (set! jj 0) + (do ((j 0 (+ j 1))) ((= j n)) + (if (not (= j jn)) + (begin + (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 +(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 + + diff --git a/collects/games/jewel/doc.txt b/collects/games/jewel/doc.txt new file mode 100644 index 0000000000..f6052bf809 --- /dev/null +++ b/collects/games/jewel/doc.txt @@ -0,0 +1,34 @@ +** To play _Jewel_, run the "Games" application. ** + +The board is an 8x8 array of jewels of 7 types. You need to get 3 or +more in a row horizontally or vertically in order to score points. You +can swap any two jewels that are next to each other up and down or +left and right. The mechanic is to either: + + * Click the mouse on the first one, then drag in the direction for + the swap. + + * Move a bubble using the arrow keys, lock the bubble to a jewel with + the space bar, and the swap the locked jewel with another by using + the arrow keys. Space unlocks a locked bubble without swapping. + +Jewels can only be swapped if after the swap there are at least 3 or +more same shape or color in a row or column. Otherwise the jewels +return to their original position. There is a clock shown on the +left. When it counts down to 0 the game is over. Getting 3 in a row +adds time to the clock. + +Hit spacebar to start a new game then select the difficulty number by +pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to exit. +During playing press 'p' to pause the game. + +The code is released under the LGPL. +The code is a conversion of Dave Ashley's C program to Scheme with some +modifications and enhancements. + +Enjoy. + +Peter Ivanyi + +(Matthew edited Peter's code and help text a little: added keyboard + support, plus other minor changes.) diff --git a/collects/games/jewel/info.ss b/collects/games/jewel/info.ss new file mode 100644 index 0000000000..2574bf34df --- /dev/null +++ b/collects/games/jewel/info.ss @@ -0,0 +1,5 @@ +(module info (lib "infotab.ss" "setup") + (define name "Jewel") + (define doc.txt "doc.txt") + (define game "jewel.scm") + (define game-set "Puzzle Games")) diff --git a/collects/games/jewel/jewel.png b/collects/games/jewel/jewel.png new file mode 100644 index 0000000000..e4b2e67d0a Binary files /dev/null and b/collects/games/jewel/jewel.png differ diff --git a/collects/games/jewel/jewel.scm b/collects/games/jewel/jewel.scm new file mode 100644 index 0000000000..0789681470 --- /dev/null +++ b/collects/games/jewel/jewel.scm @@ -0,0 +1,1824 @@ +; FIXME: +; - object rotation axis could be random per type + +(module jewel mzscheme + + (require (lib "unit.ss") + (lib "string.ss") + (lib "class.ss") + (lib "file.ss") + (lib "mred.ss" "mred") + (lib "gl.ss" "sgl") + (lib "gl-vectors.ss" "sgl") + (only (lib "sgl.ss" "sgl") get-gl-version-number) + "shapes.scm" + "array.scm" + "text.scm" + "../show-help.ss" + ) + + (provide game-unit) + + + (define game-unit + (unit + (import) + (export) + + ; ----------------------------------------------------------------- + ; global constants + ; ----------------------------------------------------------------- + + ; 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) + + ; table of high scores, loaded from a file + (define high-scores #( ("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) + + (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) + (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)) + (if (equal? gamestate 'PLAYING) + (begin + (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)])) + ) + ) + ) + + (super-instantiate () ) + ) + ) + + + ; defines a new OpenGL canvas, handling mouse and rendering, etc + (define jewel-canvas% + (class* canvas% () + (inherit with-gl-context swap-gl-buffers) + + (define initialised #f) + + (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/override (on-paint) + (with-gl-context + (lambda () + (if (and initialised expose) + (expose) + ) + (swap-gl-buffers) + ) + ) + ) + + (define/override (on-size width height) + (with-gl-context + (lambda () + (if (not initialised) + (begin + (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 '(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. Probably OpenGL is not supported by" + " the current display, or it was disabled when PLT Scheme was" + " configured and compiled.") + #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-table-put! elem 'type type ) + (hash-table-put! elem 'angle (random 360) ) + (hash-table-put! elem 'ax 0.0 ) + (hash-table-put! elem 'ay 1.0 ) + (hash-table-put! elem 'az 0.0 ) + (hash-table-put! elem 'fall 0.0 ) + (hash-table-put! elem 'speed 0.0 ) + (hash-table-put! elem 'vanish 1.0 ) + (hash-table-put! elem 'dx 0.0 ) + (hash-table-put! elem 'dy 0.0 ) + (hash-table-put! elem 'swapping 0 ) + + (cond + ; one color per type + ; one shape for all type + ( (= jewel-difficulty 1) + (hash-table-put! elem 'color type) + (hash-table-put! elem 'shape diff-shape) + ) + ; one color for all type + ; one shape per type + ( (= jewel-difficulty 2) + (hash-table-put! elem 'color diff-color) + (hash-table-put! elem 'shape type) + ) + ; one color per type + ; random shape + ( (= jewel-difficulty 3) + (hash-table-put! elem 'color type) + (hash-table-put! elem 'shape (random 7)) + ) + ; random color + ; one shape per type + ( (= jewel-difficulty 4) + (hash-table-put! elem 'color (random 7)) + (hash-table-put! elem 'shape type) + ) + ; default + ; one color per type + ; one shape per type + ( else + (hash-table-put! elem 'color type) + (hash-table-put! 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)) + (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-table 'equal)) ) + (vector-set! row ix elem) + (element-init iy ix) + ) + ) + ); end of let + ) + ) + + + (define (element-get iy ix prop) + (hash-table-get (vector-ref (vector-ref element-db iy) ix) + prop (lambda () #f)) + ) + + + (define (element-set! iy ix prop value) + (let* + ( (elem (vector-ref (vector-ref element-db iy) ix)) ) + (hash-table-put! elem 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) + (let* + ( (elem1 (vector-ref (vector-ref element-db iy) ix)) + (elem2 (vector-ref (vector-ref element-db jy) jx)) + ) + (hash-table-for-each + elem1 + (lambda (key val) (hash-table-put! 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-table 'equal)) + (define score-key 0) + (define score-fade 0.01) + + (define (score-add x y z fade value) + (let* + ( (elem (make-hash-table 'equal)) ) + (hash-table-put! elem 'x x) + (hash-table-put! elem 'y y) + (hash-table-put! elem 'z z) + (hash-table-put! elem 'fade fade) + (hash-table-put! elem 'value value) + + (hash-table-put! score-numbers score-key elem) + (set! score-key (+ score-key 1)) + ) + ) + + (define (score-set! elem prop val) + (hash-table-put! elem prop val) + ) + + (define (score-del! score-key) + (hash-table-remove! score-numbers score-key) + ) + + (define (score-get elem prop) + (hash-table-get elem prop) + ) + + (define (score-for-each proc table) + (hash-table-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)) + ) + (if (>= idx 0) + (begin + (if (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) + (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)))))) + + + (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"))) + + (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) + (let* + ( (score #f) + (exit? #f) + ) + + (do ((i 0 (+ i 1))) ((or exit? (= i (vector-length high-scores)))) + (set! score (vector-ref high-scores i)) + (if (> 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) + + ; 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) + (if (= (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") + ) + + + (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-table 'equal)) + + (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) + + ; 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) + ) + ) + + (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) ) + + (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)) + + (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)) + + (glEnable GL_DEPTH_TEST) + + (glShadeModel GL_SMOOTH) + (glClearColor 0.0 0.0 0.0 1.0) + (glClear GL_COLOR_BUFFER_BIT) + (glClear GL_DEPTH_BUFFER_BIT) + + (glDisable GL_BLEND) + (glBlendFunc GL_ONE GL_ONE) + + (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)) + + (if (= (element-get iy ix 'vanish) 0.0) + (let ( (finished -1) ) + (do ((k (- iy 1) (- k 1))) ((or (< k 0) (> finished -1))) + (if (not (= (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)) + ) + (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))) + (if (>= jewel-stage nextlevel) + (begin + (set! jewel-stage (- jewel-stage nextlevel)) + (set! jewel-level (+ jewel-level 1)) + (set! jewel-decay (+ jewel-decay decayadd)) + ) + ) + ) + ) + + + (define (declife) + (set! jewel-life (- jewel-life jewel-decay)) + (if (< 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) + (if (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) + (if (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)) + (if (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))) + (if (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) + (if (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) + (if (equal? gamestate 'PLAYING) + (begin + (declife) + (if tryswap? + (set! action-mode 'ACTION-SWAPPING) + ) + ) + ) + ) + ( (ACTION-SWAPPING ACTION-UNSWAPPING) + (if (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)) + (if (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) + ) + ) + ) + ) + ) + + (if (= 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)) + (if (< 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) + ) + ) + ) + ) + ) + (if (> 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)) + (if (> 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) + ) + ) + ) + ) + ) + (if (= 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)) + #t + ) + ) + + + ; ----------------------------------------------------------------- + ; 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 (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)) + + (if (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) + + ) + + (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)) + (if (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)))) + (if (= (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) + + (if (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) + + (if (and (equal? gamestate 'PLAYING) + (= cposx ix) (= cposy iy)) + (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) + (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) + + ; 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) + + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE + (vector->gl-float-vector (vector-ref color-map 6))) + ; if not playing cover with dim square + (if (equal? gamestate 'GAME-OVER) + (high-score-render) + ) + + (if (equal? gamestate 'DIFFICULTY) + (difficulty-render) + ) + ) + + ; ----------------------------------------------------------------- + ; Mouse handling + ; ----------------------------------------------------------------- + + (define last-click-x #f) + (define last-click-y #f) + (define num-unproductive-clicks 0) + + (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)) + ) + (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 + ) + ) + ) + ) + + + (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 + (if (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) + ) + ) + ) + ) + ) + + (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)) + + ; ----------------------------------------------------------------- + ; MAIN + ; ----------------------------------------------------------------- + + (jewel-init-game) + + (define show-jewel-help + (show-help (list "games" "jewel") + "Jewel Help" #f)) + + (define *MAIN_WINDOW* + (new jewel-frame% + (label "Jewel") + (min-width 640) + (min-height 480) + (stretchable-width #f) + (stretchable-height #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.scm b/collects/games/jewel/shapes.scm new file mode 100644 index 0000000000..1171481dfd --- /dev/null +++ b/collects/games/jewel/shapes.scm @@ -0,0 +1,750 @@ +(module shapes mzscheme + +(require (lib "gl.ss" "sgl") + (lib "gl-vectors.ss" "sgl") + (prefix gl- (lib "sgl.ss" "sgl")) +) + +(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)) + ) +) + + +; ------------------------------------------------------------------- +(define (makedots size) + (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)) + (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) + ) + (glEnd) + (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 ) + ) +) + + +(define (hex-point n size) + (apply glVertex3f (map (lambda (x) (* x size)) + (vector-ref bucky-points n))) +) + + +(define (hex p1 p2 p3 p4 p5 p6 size) + (norm (vector-ref bucky-points p1) + (vector-ref bucky-points p3) + (vector-ref bucky-points p2) + 1.0) + (glPolygonMode GL_FRONT GL_FILL) + (glBegin GL_POLYGON) + (hex-point p6 size) + (hex-point p5 size) + (hex-point p4 size) + (hex-point p3 size) + (hex-point p2 size) + (hex-point p1 size) + (glEnd) + (glPolygonMode GL_FRONT GL_FILL) +) + + +(define (pent p1 p2 p3 p4 p5 size) + (norm (vector-ref bucky-points p1) + (vector-ref bucky-points p3) + (vector-ref bucky-points p2) + 1.0) + (glBegin GL_TRIANGLE_STRIP) + (hex-point p1 size) + (hex-point p5 size) + (hex-point p2 size) + (hex-point p4 size) + (hex-point p3 size) + (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) + (hex 9 10 32 30 31 33 size) + (hex 5 6 28 26 27 29 size) + (hex 0 25 59 58 1 3 size) + (hex 11 58 59 19 20 12 size) + (hex 21 22 24 25 00 23 size) + (hex 30 32 37 35 44 45 size) + (hex 26 28 33 31 42 43 size) + (hex 15 17 24 22 38 39 size) + (hex 15 16 18 20 19 17 size) + (hex 38 51 49 48 50 39 size) + (hex 13 14 36 34 35 37 size) + (hex 16 46 47 34 36 18 size) + (hex 21 23 29 27 40 41 size) + (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) + + (pent 1 58 11 7 2 size) + (pent 8 13 37 32 10 size) + (pent 4 9 33 28 6 size) + (pent 0 3 5 29 23 size) + (pent 17 19 59 25 24 size) + (pent 12 20 18 36 14 size) + (pent 30 45 55 42 31 size) + (pent 21 41 51 38 22 size) + (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) + +) + + +; ------------------------------------------------------------------- + + +(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) + + (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 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 (- 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) 0.0); + (glVertex3f (- sizex) (- bsizey) (- sizez)); + (glVertex3f sizex (- bsizey) (- sizez)); + (glVertex3f sizex (- bsizey) sizez); + (glVertex3f (- sizex) (- bsizey) sizez); + +; setmaterial(blue); + + (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 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 (- 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 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) sizey (- bsizez)); + (glVertex3f (- sizex) bsizey (- sizez)); + (glVertex3f sizex bsizey (- sizez)); + (glVertex3f sizex sizey (- bsizez)); + + (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 sizex sizey (- bsizez)); + (glVertex3f bsizex sizey (- sizez)); + (glVertex3f bsizex (- sizey) (- 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 (- sizey) 0.0); + (glVertex3f sizex (- bsizey) (- sizez)); + (glVertex3f bsizex (- sizey) (- sizez)); + (glVertex3f bsizex (- sizey) sizez); + (glVertex3f sizex (- bsizey) sizez); + + (glEnd); + +; 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 (- 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 (- bsizey) sizez); + (glVertex3f bsizex (- sizey) 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 (- 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 (- 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))) + (if (> 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) + ) + + (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))) + (if (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) + + ) + + + ) +) + + +; ------------------------------------------------------------------- + +(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)) + (set! a (/ (* i 3.1415928 2.0) dsides)) + (vector-set! x i (* (cos 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) + ) + + (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))) + (set! j (if (< i dsides) i (- i dsides))) + (if (= t 0) + (set! j (- dsides 1 j)) + ) + (if (> 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) ) + ) + (glVertex3f (vector-ref x j) p2 (vector-ref z j)) + (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 (makepyramid size) + (glEnable GL_NORMALIZE) + + (glBegin GL_QUADS) + (glNormal3f 0.0 (- size) 0.0) + (glVertex3f size (- size) size) + (glVertex3f (- size) (- size) size) + (glVertex3f (- size) (- size) (- size)) + (glVertex3f size (- size) (- size)) + (glEnd) + + (glBegin GL_TRIANGLE_FAN) + (glVertex3f 0.0 size 0.0) + + (glVertex3f size (- size) size) + (glNormal3f 2.0 -1.0 0.0) + (glVertex3f size (- size) (- size)) + (glNormal3f 0.0 -1.0 -2.0) + (glVertex3f (- size) (- size) (- size)) + (glNormal3f -2.0 -1.0 0.0) + (glVertex3f (- size) (- size) size) + (glNormal3f 0.0 -1.0 2.0) + (glVertex3f size (- size) size) + (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) + + #( 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) + ) +) + +; ------------------------------------------------------------------- + +(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) + ) + + (glEnable GL_NORMALIZE) + (do ((i 0 (+ i 1))) ((= i 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)) + ) + + ; 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)) + (set! j (+ i 1)) + (if (>= 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) + (norm (vector->list p0) + (vector->list p1) + (vector->list p2) + 1.0) + (glVertex3fv (vector->gl-float-vector p2)) + + (vector-set! p1 0 (vector-ref x1 j)) + (vector-set! p1 1 (vector-ref y1 j)) + (vector-set! p1 2 0.0) + (norm (vector->list p0) + (vector->list p2) + (vector->list p1) + 1.0) + (glVertex3fv (vector->gl-float-vector p1)) + ) + + (glEnd) + + ; 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)) + (set! j (+ i 1)) + (if (>= 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) + (norm (vector->list p0) + (vector->list p1) + (vector->list p2) + -1.0) + (glVertex3fv (vector->gl-float-vector p2)) + + (vector-set! p1 0 (vector-ref x1 j)) + (vector-set! p1 1 (vector-ref y1 j)) + (vector-set! p1 2 0.0) + (norm (vector->list p0) + (vector->list p2) + (vector->list p1) + -1.0) + (glVertex3fv (vector->gl-float-vector p1)) + ) + + (glEnd) + + ) +) + + +; ------------------------------------------------------------------- + +) ; end of module + diff --git a/collects/games/jewel/text.scm b/collects/games/jewel/text.scm new file mode 100644 index 0000000000..9c400875ee --- /dev/null +++ b/collects/games/jewel/text.scm @@ -0,0 +1,230 @@ +(module text mzscheme + + (require (lib "mred.ss" "mred") + (lib "class.ss") + (lib "gl.ss" "sgl") + (lib "gl-vectors.ss" "sgl") + ) + + (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") + + ) + ) + + + ; font database is a hash table + (define font-db (make-hash-table 'equal)) + (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) + ) + ) + + + ; 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-table-put! 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-table-get 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-table-get 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) + + (define/override (on-paint) + (with-gl-context + (lambda () + (glClearColor 0.0 0.0 0.0 0.0) + (glClear GL_COLOR_BUFFER_BIT) + (glClear GL_DEPTH_BUFFER_BIT) + + (my-display) + (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))) + ) + ) + + ; 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) + ) + |# + +) ; end of module + +