home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / guile-docs / tcltk-wkshp / talk-html / driver.ggl < prev    next >
Encoding:
Text File  |  1995-07-08  |  18.0 KB  |  743 lines
  1. ;;; Copyright (C) 1995 Cygnus Support, Inc.
  2. ;;; 
  3. ;;; This program is free software; you can redistribute it and/or modify
  4. ;;; it under the terms of the GNU General Public License as published by
  5. ;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;; any later version.
  7. ;;; 
  8. ;;; This program is distributed in the hope that it will be useful,
  9. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;; GNU General Public License for more details.
  12. ;;; 
  13. ;;; You should have received a copy of the GNU General Public License
  14. ;;; along with this software; see the file COPYING.  If not, write to
  15. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ;;;
  17. ;;; As a special exception, Cygnus Support gives permission
  18. ;;; for additional uses of the text contained in its release of this library.
  19. ;;;
  20. ;;; The exception is that, if you link this library with other files
  21. ;;; to produce an executable, this does not by itself cause the
  22. ;;; resulting executable to be covered by the GNU General Public License.
  23. ;;; Your use of that executable is in no way restricted on account of
  24. ;;; linking this library code into it.
  25. ;;;
  26. ;;; This exception does not however invalidate any other reasons why
  27. ;;; the executable file might be covered by the GNU General Public License.
  28. ;;;
  29. ;;; This exception applies only to the code released by 
  30. ;;; Cygnus Support as part of this library.  If you copy
  31. ;;; code from other releases distributed under the terms of the GPL into a copy of
  32. ;;; this library, as the General Public License permits, the exception does
  33. ;;; not apply to the code that you add in this way.  To avoid misleading
  34. ;;; anyone as to the status of such modified files, you must delete
  35. ;;; this exception notice from such code.
  36. ;;;
  37. ;;; If you write modifications of your own for this library, it is your choice
  38. ;;; whether to permit this exception to apply to your modifications.
  39. ;;; If you do not wish that, delete this exception notice.  
  40.  
  41.  
  42.  
  43. (require 'random)
  44. (define (coin-toss . from)
  45.   (list-ref from (random (length from))))
  46.  
  47.  
  48.  
  49. (define (glut-just-once thunk)
  50.   (thunk))
  51.  
  52.  
  53.  
  54.  
  55. (define (glutReshapeFunc-callout w h)
  56.   (glut-just-once (lambda () (glutReshapeFunc  w h))))
  57.  
  58. (define (glutDefaultReshape w h)
  59.   (glMatrixMode GL_PROJECTION)
  60.   (glLoadIdentity)
  61.   (glFrustum -1 1 -1 1 1 200)
  62.   (glMatrixMode GL_MODELVIEW)
  63.   (glViewport 0 0 w h))
  64.  
  65. (define glutReshapeFunc glutDefaultReshape)
  66.  
  67.  
  68.  
  69. (define (glutDisplayFunc-callout)
  70.   (glut-just-once (lambda () (glutDisplayFunc))))
  71. (define (glutDefaultDisplay) #t)
  72. (define glutDisplayFunc glutDefaultDisplay)
  73.  
  74.  
  75.  
  76. (define (glutKeyboardFunc-callout char mouse-x mouse-y)
  77.   (glut-just-once (lambda () (glutKeyboardFunc char mouse-x mouse-y))))
  78. (define (glutDefaultKeyboardFunc char mouse-x mouse-y) #t)
  79. (define glutKeyboardFunc glutDefaultKeyboardFunc)
  80.  
  81.  
  82.  
  83. (define (glutMouseFunc-callout button type x y)
  84.   (glut-just-once (lambda () (glutMouseFunc button type x y))))
  85. (define (glutDefaultMouseFunc button type x y) #f)
  86. (define glutMouseFunc glutDefaultMouseFunc)
  87.  
  88.  
  89.  
  90.  
  91. (define (glutPassiveMotionFunc-callout x y)
  92.   (glut-just-once (lambda () (glutPassiveMotionFunc x y))))
  93. (define (glutDefaultPassiveMotionFunc button type x y) #f)
  94. (define glutPassiveMotionFunc glutDefaultPassiveMotionFunc)
  95.  
  96.  
  97.  
  98.  
  99. (define (glutIdleFunc-callout)
  100.   (glut-just-once (lambda () (glutIdleFunc))))
  101. (define (glutDefaultIdleFunc) #f)
  102. (define glutIdleFunc glutDefaultIdleFunc)
  103.  
  104.  
  105. (define doubling #t)
  106. (define filling #f)
  107. (glutInitDisplayMode (logior (if doubling GLUT_DOUBLE 0) GLUT_RGB GLUT_DEPTH))
  108. (glutCreateWindow "the thing")
  109. (use-glutDisplayFunc #t)
  110. (use-glutIdleFunc #t)
  111. (use-glutReshapeFunc #t)
  112. (use-glutIdleFunc #t)
  113. (use-glutKeyboardFunc #t)
  114. (use-glutMouseFunc #t)
  115. (glClearDepth 1.0)
  116. (glClearColor 0.0 0.0 0.0 0.0)
  117.  
  118.  
  119.  
  120. (define fogColor #s(0.0 0.0 0.0 1.0))
  121.  
  122. (glEnable GL_FOG)
  123. (glFogi  GL_FOG_MODE GL_LINEAR)
  124. (glHint GL_FOG_HINT GL_NICEST)
  125. (glFogf  GL_FOG_START 3.0)
  126. (glFogf  GL_FOG_END 5.0)
  127. (glFogfv  GL_FOG_COLOR fogColor)
  128. (glClearColor 0.0 0.0 0.0 1.0)
  129. (glDepthFunc GL_LESS)
  130. (glEnable GL_DEPTH_TEST)
  131. (glShadeModel GL_FLAT)
  132.  
  133.  
  134.  
  135. (define rotation '(0 0 0 0 0 0))
  136. (define v-rotation '(0 0 0 0 0 0))
  137. (define a-rotation '(0 0 0 0 0 0))
  138. (define dur-rotation '(0 0 0 0 0 0))
  139.  
  140. (define (clip mag val)
  141.   (if (>= mag (abs val))
  142.       val
  143.       (if (<= 0 val)
  144.       mag
  145.       (- mag))))
  146.  
  147. (define (rotation-tick)
  148.   (set! rotation
  149.     (map + rotation v-rotation))
  150.   (set! v-rotation
  151.     (map (lambda (a b)
  152.            (clip .005 (+ a b)))
  153.          v-rotation a-rotation))
  154.   (set! a-rotation
  155.     (map (lambda (a d)
  156.            (if (= d 0)
  157.            ((coin-toss + -)
  158.             (random 0.0006))
  159.            a))
  160.          a-rotation
  161.          dur-rotation))
  162.   (set! dur-rotation
  163.     (map (lambda (n)
  164.            (if (= n 0)
  165.            (+ 19 (random 10))
  166.            (+ -1 n)))
  167.          dur-rotation)))
  168.  
  169.  
  170. (define (glutDisplayFunc)
  171.   (glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
  172.   (glColor3f (abs (- (car rotation) (floor (car rotation))))
  173.          (abs (- (cadr rotation) (floor (car rotation))))
  174.          (abs (- (caddr rotation) (floor (car rotation)))))
  175.   (glLineWidth 4)
  176.   (map
  177.    (lambda (a ax)
  178.      (apply glRotatef a ax))
  179.    (cdddr rotation)
  180.    '((1 0 0) (0 1 0) (0 0 1)))
  181.   ((if filling glutSolidIcosahedron glutWireIcosahedron))
  182.   (if doubling
  183.       (glutSwapBuffers))
  184.   (glFlush))
  185.  
  186.  
  187. (define attention (list 0.0 0.0 -4.0))
  188.  
  189. (define (glutReshapeFunc w h)
  190.   (glViewport 0 0 w h)
  191.   (glMatrixMode GL_PROJECTION)
  192.   (glLoadIdentity)
  193.   (gluPerspective  45.0 (/ w h) 3.0 5.0)
  194.   (glMatrixMode GL_MODELVIEW)
  195.   (glLoadIdentity)
  196.   (apply glTranslatef attention))
  197.  
  198. (define zooming #f)
  199. (define (glutKeyboardFunc c x y)
  200.   (cond
  201.    ((eq? c #\q) (exit))
  202.    ((eq? c #\z) (set! zooming #t) (set! zoomed 0))
  203.    (else #f)))
  204.  
  205. (define (glutMain)
  206.   (glutMainLoop))
  207.  
  208.  
  209.  
  210. (define zoomed 0)
  211. (define (glutIdleFunc)
  212.   (rotation-tick)
  213.   (if zooming
  214.       (if (< zoomed 2.9)
  215.       (begin
  216.         (glLoadIdentity)
  217.         (apply glTranslatef attention)
  218.         (glTranslatef 0 0 zoomed)
  219.         (set! zoomed (+ zoomed .038)))
  220.       (begin
  221.         (set! zooming #f)
  222.         (set! zoomed 0)
  223.         (goto-break))))
  224.   (glutPostRedisplay))
  225.  
  226.  
  227. (define (glutMouseFunc type x y z)
  228.   (set! zooming #t)
  229.   (set! zoomed 0))
  230.  
  231.  
  232.  
  233. ;; How big a canvas?
  234. ;;
  235. (define play-w 520)
  236. (define play-h 520)
  237.  
  238. ;; Where does the play area start
  239. ;;
  240. (define bounds-x 4)
  241. (define bounds-y 4)
  242.  
  243. ;; Where is the paddle ul cornder?
  244. ;;
  245. (define paddle-x 0)
  246. (define paddle-y 375)
  247.  
  248. ;; Where is the puck center?
  249. ;;
  250. (define puck-x 0)
  251. (define puck-r 6)
  252. (define puck-y (- paddle-y puck-r 1))
  253.  
  254. ;; Paddle size:
  255. ;;
  256. (define paddle-height 10)
  257. (define paddle-width 64)
  258.  
  259. ;; How big is the in-bounds area for the puck?
  260. ;;
  261. (define bounds-w 512)
  262. (define bounds-h puck-y)
  263.  
  264. ;; How many blocks per row?
  265. ;;
  266. (define n-row 16)
  267.  
  268. ;; Row y positions
  269. ;;
  270. (define row0-y 32)
  271. (define row1-y 64)
  272.  
  273. ;; Individual block size
  274. ;;
  275. (define row-height 16)
  276. (define row-width (/ bounds-w n-row))
  277.  
  278. ;; Each entry either the name of a canvas
  279. ;; item for the block or #f if the block
  280. ;; has been eliminated:
  281. ;;
  282. (define row0 (make-vector n-row #f))
  283. (define row1 (make-vector n-row #f))
  284. (define row0-ref (make-vector n-row #f))
  285. (define row1-ref (make-vector n-row #f))
  286.  
  287.  
  288. ;; Puck dynamic
  289. ;;
  290. (define puck-max-vx puck-r)
  291. (define puck-max-vy puck-r)
  292. (define puck-init-init-vx 2)
  293. (define puck-init-init-vy -2)
  294. (define puck-init-vx 2)
  295. (define puck-init-vy -2)
  296. (define puck-vx puck-init-vx)
  297. (define puck-vy puck-init-vy)
  298. (define (coin-toss . from)
  299.   (list-ref from (random (length from))))
  300. (define (puck-tick)
  301.   (let ((old-x puck-x)
  302.     (old-y puck-y)
  303.     (new-puck-x 0)
  304.     (new-puck-y 0))
  305.     (set! new-puck-x (+ puck-x puck-vx))
  306.     (set! new-puck-y (+ puck-y puck-vy))
  307.     (cond
  308.  
  309.      ((or (and (< new-puck-y (+ row1-y row-height))
  310.            (>= new-puck-y row1-y)
  311.            (hit-puck-at-game-x!? row1 new-puck-x)
  312.            row1-y)
  313.       (and (< new-puck-y (+ row0-y row-height))
  314.            (>= new-puck-y row0-y)
  315.            (hit-puck-at-game-x!? row0 new-puck-x)
  316.            row0-y)
  317.       (and (< new-puck-y 0)
  318.            0))
  319.       => (lambda (yref)
  320.        (report-score)
  321.        (set! puck-vy (- puck-vy))
  322.        (set! new-puck-y (+ yref (- new-puck-y yref)))
  323.        (if (= 0 n-blocks)
  324.            (begin
  325.          (win-level)
  326.          (set! old-y new-puck-y)
  327.          (set! old-x new-puck-x)))))
  328.  
  329.      ((<= bounds-h new-puck-y)
  330.       (cond
  331.        ((paddle-sweet? new-puck-x)
  332.     (begin
  333.       (set! puck-vy (- puck-vy))
  334.       (set! new-puck-y (+ bounds-h (- bounds-h new-puck-y)))))
  335.        ((paddle-sour? new-puck-x)
  336.     (begin
  337.       (set! puck-vy (- puck-vy))
  338.       (let ((total (+ (* puck-vx puck-vx) (* puck-vy puck-vy))))
  339.         (set! puck-vx ((coin-toss + -) (random puck-init-vx)))
  340.         (set! puck-vy (- (sqrt (- total (* puck-vx puck-vx))))))
  341.       (set! new-puck-y (+ bounds-h (- bounds-h new-puck-y)))))
  342.        ((<= (+ bounds-h 90) new-puck-y)
  343.     (lose-level)
  344.     (set! old-y new-puck-y)
  345.     (set! old-x new-puck-x))))
  346.        
  347.  
  348.      ((< new-puck-x 0)
  349.       (begin
  350.     (set! puck-vx (- puck-vx))
  351.     (set! new-puck-x (- new-puck-x))))
  352.  
  353.      ((<= bounds-w new-puck-x)
  354.       (begin
  355.     (set! puck-vx (- puck-vx))
  356.     (set! new-puck-x (+ bounds-w (- bounds-w new-puck-x))))))
  357.      
  358.     (move-puck  (- new-puck-x old-x) (- new-puck-y old-y))))
  359.  
  360.  
  361. (define (paddle-sweet? x)
  362.   (and (> (abs puck-vx) .00001)
  363.        (let ((r (/ paddle-width 2)))
  364.      (< (abs (- x (+ r paddle-x)))
  365.         r))))
  366.  
  367. (define (paddle-sour? x)
  368.   (let ((r (/ paddle-width 2)))
  369.     (< (abs (- x (+ r paddle-x)))
  370.        (+ (* 3 puck-r) r))))
  371.  
  372.  
  373. (define game-playable #t)
  374. (define game-playing #f)
  375. (define score 0)
  376. (define pucks-per-game 3)
  377. (define n-pucks pucks-per-game)
  378. (define n-blocks #f)
  379.  
  380.  
  381.  
  382. (define (new-level)
  383.   ; (.game.c 'delete 'all)
  384.   ; (set! score-report #f)
  385.   ; (set! puck-report #f)
  386.   ; (set! game-over-report #f)
  387.   (make-row! row0 row0-y)
  388.   (make-row! row1 row1-y)
  389.   (make-row! row0-ref row0-y)
  390.   (make-row! row1-ref row1-y)
  391.   (set! n-blocks (* 2 n-row))
  392.   (new-puck)
  393.   (new-paddle)
  394.   (report-game-state))
  395.  
  396. (define (new-game)
  397.   (set! game-playable #t)
  398.   (set! game-playing #f)
  399.   (set! puck-init-vx puck-init-init-vx)
  400.   (set! puck-init-vy puck-init-init-vy)
  401.   (new-level)
  402.   (set! n-pucks pucks-per-game)
  403.   (set! score 0)
  404.   (report-game-state))
  405.  
  406.  
  407.  
  408. (define (projection)
  409.   (glMatrixMode GL_PROJECTION)
  410.   (glLoadIdentity)
  411.   (glFrustum (- (/ play-w 2)) (/ play-h 2) 
  412.          (/ play-w 2) (- (/ play-h 2)) 
  413.          100 5000)
  414.   (glMatrixMode GL_MODELVIEW)
  415.   (glLoadIdentity))
  416.  
  417. (define extra-angle 0)
  418. (define extra-dist 0)
  419. (define angle-v 0)
  420. (define dist-v 13)
  421. (define tumbling #f)
  422. (define (view)
  423.   (glLoadIdentity)
  424.   (glTranslatef 0 0 (- (+ 200 extra-dist)))
  425.   (glRotatef (+ 15 extra-angle) 1 0 0)
  426.   (glTranslatef (- (/ play-w 2)) (- (/ play-h 2)) 0))
  427.  
  428. (define (tumble)
  429.   (set! extra-angle (+ extra-angle angle-v))
  430.   (set! extra-dist (+ extra-dist dist-v))
  431.   (if (> extra-dist 6000)
  432.       (quit))
  433.   (glutPostRedisplay))
  434.   
  435.  
  436. (define screen-w 0)
  437. (define screen-h 0)
  438. (define (reshape w h)
  439.   (glViewport 0 0 w h)
  440.   (set! screen-w w)
  441.   (set! screen-h h)
  442.   (projection))
  443.  
  444. (define (break-glutKeyboardFunc c x y)
  445.   (cond
  446.    ((eq? c #\q) (exit))
  447.    ((eq? c #\t)
  448.     (set! angle-v 4)
  449.     (set! dist-v 13)
  450.     (set! tumbling #t)
  451.     (set! glutIdleFunc (lambda () (if tumbling (tumble)))))
  452.    ((eq? c #\p)
  453.     (if (eq? x-glutIdleFunc glutIdleFunc)
  454.     (set! glutIdleFunc (lambda () (if tumbling (tumble))))
  455.     (set! glutIdleFunc x-glutIdleFunc)))
  456.    (else #f)))
  457.  
  458.  
  459. ;; Make the two rows:
  460. ;;
  461. (define (make-row! v y)
  462.   (let loop ((n 0))
  463.     (if (= n 16)
  464.     v
  465.     (begin
  466.       (vector-set! v n (cons (+ (/ row-width 2) bounds-x (* n row-width))
  467.                  (+ (/ row-height 2) bounds-y y)))
  468.       (loop (+ n 1))))))
  469.  
  470.  
  471. (define (hit-puck-at-game-x!? row x-game)
  472.   (let* ((x (- x-game bounds-x))
  473.      (i (inexact->exact (floor (/ x row-width)))))
  474.     (and (>= i 0)
  475.      (< i (vector-length row))
  476.      (vector-ref row i)
  477.      (begin
  478.        (draw-without-clearing (lambda () #t) #t)
  479.        (vector-set! row i #f)
  480.        (set! n-blocks (- n-blocks 1))
  481.        (set! score (+ 1 score))
  482.        #t))))
  483.  
  484. (define (draw-row row ref y color)
  485.   (glPushMatrix)
  486.   (array-for-each
  487.    (lambda (on off)
  488.      (if on
  489.      (glColor3fv color)
  490.      (glColor3fv #s(0.0 0.0 0.0)))
  491.      (glPushMatrix)
  492.      (let ((coord (or on off)))
  493.        (glTranslatef (car coord) (cdr coord) 0)
  494.        (glScalef (/ row-width 4) (/ row-height 4) 1)
  495.        (glLineWidth 1)
  496.        (glutWireCube 4.0)
  497.        (glLineWidth 0))
  498.      (glPopMatrix))
  499.    row ref)
  500.   (glPopMatrix))
  501.     
  502.  
  503.  
  504. ;; Drawing the paddle:
  505. ;;
  506. (define paddle-color '#s(0.2 1.0 0.6))
  507. (define paddle #f)
  508. (define (new-paddle)
  509.   (set! paddle
  510.     (cons (+ bounds-x paddle-x (/ paddle-width 2))
  511.           (+ bounds-y paddle-y (/ paddle-height 2)))))
  512.  
  513.  
  514. (define (draw-paddle color)
  515.   (if paddle
  516.       (begin
  517.     (glPushMatrix)
  518.     (glColor3fv color)
  519.     (glTranslatef (car paddle) (cdr paddle) 0)
  520.     (glScalef paddle-width paddle-height 8)
  521.     (glutWireCube 1.0)
  522.     (glPopMatrix))))
  523.  
  524. (define (draw-puck color)
  525.   (if paddle
  526.       (begin
  527.     (glPushMatrix)
  528.     (glColor3fv color)
  529.     (glTranslatef (car puck) (cdr puck) 0)
  530.     (glScalef puck-r puck-r puck-r)
  531.     (glutWireCube 1.0)
  532.     (glPopMatrix))))
  533.  
  534. (define puck-color #s(1.0 0.3 0.3))
  535.  
  536. (define draw-without-clearing
  537.   (let* ((cap-max 5)
  538.      (cap 0)
  539.      (discharge (lambda (th)
  540.               (if (not (= 0 cap))
  541.               (begin
  542.                 (set! cap 0)
  543.                 (th)))))
  544.      (more-likely (lambda (th)
  545.             (set! cap (+ 1 cap))
  546.             (if (= cap cap-max)
  547.                 (discharge th))))
  548.      (cap-2-max 5)
  549.      (cap-2 0)
  550.      (discharge-2 (lambda (th)
  551.             (if (not (= 0 cap-2))
  552.                 (begin
  553.                   (set! cap-2 0)
  554.                   (th)))))
  555.      (more-likely-2 (lambda (th)
  556.             (set! cap-2 (+ 1 cap-2))
  557.             (if (= cap-2 cap-2-max)
  558.                 (discharge-2 th)))))
  559.     (lambda (thunk . opt)
  560.       (begin
  561.     (glPushMatrix)
  562.     (view)
  563.     (thunk)
  564.     (draw-paddle paddle-color)
  565.     (draw-puck puck-color)
  566.     (glFlush)
  567.     (glPushMatrix)
  568.     (glTranslatef (/ play-w 2) (/ play-h 2) (/ play-h 2))
  569.     (glColor3fv #s(1.0 1.0 1.0))
  570.     (glutWireCube play-h)
  571.     (glPopMatrix)
  572.     (if (<= (- puck-y puck-r) (+ row1-y row-height))
  573.         (begin
  574.           (more-likely (lambda () (draw-row row1 row1-ref row1-y '#s(1.0 0.3 1.0))))
  575.           (if (<= (- puck-y puck-r) (+ row0-y row-height))
  576.           (more-likely-2 (lambda () (draw-row row0 row0-ref row0-y '#s(1.0 1.0 0.3))))
  577.           (discharge-2 (lambda () (draw-row row0 row0-ref row0-y '#s(1.0 1.0 0.3))))))
  578.         (discharge (lambda () (draw-row row1 row1-ref row1-y '#s(1.0 0.3 1.0)))))
  579.     (if (not (eq? '() opt))
  580.         (begin
  581.           (set! cap 1)
  582.           (set! cap-2 1)
  583.           (discharge-2 (lambda () (draw-row row0 row0-ref row0-y '#s(1.0 1.0 0.3))))
  584.           (discharge (lambda () (draw-row row1 row1-ref row1-y '#s(1.0 0.3 1.0))))))
  585.     (glPopMatrix)))))
  586.  
  587. (define (center-paddle-at-canvas-coord x)
  588.   (draw-without-clearing
  589.    (lambda ()
  590.      (draw-paddle #s(0.0 0.0 0.0))
  591.      (set! paddle-x (- x bounds-x (/ paddle-width 2)))
  592.      (new-paddle))))
  593.  
  594.  
  595. ;; Drawing the puck:
  596. ;;
  597.  
  598. (define puck #f)
  599. (define (new-puck)
  600.   (set! puck-y (- paddle-y puck-r 1))
  601.   (set! puck-x 0)
  602.   (set! puck-vx puck-init-vx)
  603.   (set! puck-vy puck-init-vy)
  604.   (set! puck (cons (+ bounds-x puck-x)
  605.            (+ bounds-y puck-y))))
  606.  
  607. (define (move-puck dx dy)
  608.   (draw-without-clearing
  609.    (lambda ()
  610.      (draw-puck #s(0.0 0.0 0.0))
  611.      (set! puck-x (+ puck-x dx))
  612.      (set! puck-y (+ puck-y dy))
  613.      (set! puck (cons (+ bounds-x puck-x)
  614.               (+ bounds-y puck-y))))))
  615.  
  616. (define (remove-puck)
  617.   (new-puck)
  618.   (glutPostRedisplay))
  619.  
  620.  
  621. (define (x-glutIdleFunc)
  622.   (if tumbling
  623.       (tumble)
  624.       (if game-playing
  625.       (puck-tick)
  626.       (set! game-playing #t))))
  627.       
  628.  
  629.  
  630. (define score-report #f)
  631. (define puck-report #f)
  632. (define game-over-report #f)
  633.  
  634. (define (lose-level)
  635.   (remove-puck)
  636.   (set! glutIdleFunc (lambda () #f))
  637.   (glutPostRedisplay))
  638.  
  639. (define (win-level)
  640.   (new-game)
  641.   (set! glutIdleFunc (lambda () #f))
  642.   (glutPostRedisplay))
  643. ;  (set! n-pucks (+ 1 n-pucks))
  644. ;  (remove-puck)
  645. ;  (set! game-playing #f)
  646. ;  (set! score (+ 25 score))
  647. ;  (set! puck-init-vy (* puck-init-vy 2))
  648. ;  (set! puck-init-vx (* puck-init-vx 2))
  649. ;  (if (< puck-init-vx puck-max-vx)
  650. ;      (new-level)
  651. ;      (set! game-playable #f))
  652. ;  (report-game-state)
  653.  
  654.  
  655. (define (report-score)
  656.   ; (and score-report (.game.c 'delete score-report))
  657.   ; (set! score-report
  658.   ; (.game.c 'create 'text 10 (+ 64 paddle-y)
  659.   ; :font "-adobe-helvetica-bold-r-normal-*-24-*-*-*-*-*-*-*"
  660.   ; :anchor 'w))
  661.   ; (.game.c 'insert score-report 0
  662.   ; (string-append "Score: " (number->string score)))
  663.   #t
  664.   )
  665.  
  666.  
  667. (define (report-game-state)  
  668.   (report-score)
  669.   ; (and puck-report (.game.c 'delete puck-report))
  670.   ; (set! puck-report
  671.   ;    (.game.c 'create 'text 200 (+ 64 paddle-y)
  672.   ;         :font "-adobe-helvetica-bold-r-normal-*-24-*-*-*-*-*-*-*"
  673.   ;         :fill (cond
  674.   ;              ((not game-playable) 'thistle4)
  675.   ;            ((eq? n-pucks 0) 'red)
  676.   ;            (else 'navy))
  677.   ;         :anchor 'w))
  678.   ; (.game.c 'insert puck-report 0
  679.   ;       (if (not game-playable)
  680.   ;           "GAME OVER"
  681.   ;           (string-append "Pucks remaining: " (number->string n-pucks))))
  682.   ; (and game-over-report (.game.c 'delete game-over-report))
  683.   ; (set! game-over-report
  684.   ;    (.game.c 'create 'text 10 (+ 96 paddle-y)
  685.   ;         :font "-adobe-helvetica-bold-o-normal-*-18-*-*-*-*-*-*-*"
  686.   ;         :fill (if (not game-playable) 'red 'ForestGreen)
  687.   ;         :anchor 'w))
  688.   ;  (.game.c 'insert game-over-report 0
  689.   ;       (cond
  690.   ;        ((not game-playable) "`P' to start a new game;  `Q' to quit")
  691.   ;        (game-playing "`P' to pause;  `Q' to quit this game")
  692.   ;        (else  "`P' to play;  `Q' to quit")))
  693.   #t
  694.   )
  695.  
  696.  
  697. (define (play-game)
  698.   (if (not game-playable) (new-game))
  699.   (set! game-playing #t)
  700.   (report-game-state)
  701.   (loop)
  702.   (report-game-state))
  703.  
  704. (define (break-glutPassiveMotionFunc x y)
  705.   (center-paddle-at-canvas-coord
  706.    (+ bounds-x (* bounds-w (/ x screen-w)))))
  707.  
  708.  
  709.  
  710. (define (break-glutReshapeFunc w h)
  711.   (if (or (not (= w 550))
  712.       (not (= h 550)))
  713.       (glutReshapeWindow 550 550)
  714.       (reshape w h)))
  715.  
  716. (define (break-glutDisplayFunc)
  717.   (glClear (logior GL_COLOR_BUFFER_BIT 0)); ((GL_DEPTH_BUFFER_BIT))
  718.   (view)
  719.   (draw-without-clearing
  720.    (lambda () #f)
  721.    #t))
  722.  
  723. (define glutPassiveMotionFunc #f)
  724. (define (goto-break)
  725.   (glDrawBuffer GL_FRONT)
  726.   (set! glutDisplayFunc break-glutDisplayFunc)
  727.   (use-glutPassiveMotionFunc #t)
  728.   (set! glutPassiveMotionFunc break-glutPassiveMotionFunc)
  729.   (set! glutReshapeFunc break-glutReshapeFunc)
  730.   (set! glutKeyboardFunc break-glutKeyboardFunc)
  731.   (set! glutIdleFunc (lambda () (lambda () (if tumbling (tumble)))))
  732.   (use-glutIdleFunc #t)
  733.   (glDisable GL_DEPTH_TEST)
  734.   (glDisable GL_FOG)
  735.   (new-game)
  736.   (use-glutPassiveMotionFunc #t)
  737.   (glutReshapeFunc 0 0)
  738.   (glutPostRedisplay))
  739.  
  740. (glutMainLoop)
  741.  
  742.  
  743.