Commits

Christian Kellermann committed 41a04c4

Initial tennis game made for T-DOSE

Comments (0)

Files changed (1)

+(use doodle miscmacros extras cairo sdl)
+
+(define width 640)
+(define height 480)
+(define *score* (list 0 0))
+(define paddle-width (round (* 0.02 width)))
+(define paddle-height (round (* 0.2 height)))
+(define *speed* 400)
+(define *ball-diameter* 20)
+(define *max-score-to-win* 3)
+(define quit? (make-parameter #f))
+
+;; debug stuff
+(define *draw-sprite-boundaries* #f)
+(define *print-sprites* #f)
+
+(define-record paddle name x y w h color direction speed react?)
+(let ((setter paddle-direction-set!))
+  (set! paddle-direction-set!
+        (lambda (paddle angle)
+          (setter paddle (modulo angle 360)))))
+
+
+(define-record ball x y d color direction speed)
+
+(let ((setter ball-direction-set!))
+  (set! ball-direction-set!
+        (lambda (ball angle)
+          (setter ball (modulo angle 360)))))
+
+(define-record-printer (ball b p)
+  (fprintf p "#,<ball ~a ~a ~a ~a ~a ~a"
+           (ball-x b)
+           (ball-y b)
+           (ball-d b)
+           (ball-color b)
+           (ball-direction b)
+           (ball-speed b)))
+
+(define init-dirs '(45 135 225 315))
+
+(define (random-direction)
+   (list-ref init-dirs (random (length init-dirs))))
+
+(define (other-direction dir)
+  (modulo (+ dir 180) 360))
+
+(define b (make-ball (/ width 2)
+                     (/ height 2)
+                     *ball-diameter*
+                     solid-white
+                     (random-direction)
+                     *speed*))
+
+(define p1 (make-paddle
+            'p1
+            paddle-width (-  (/ height 2)
+                             (/ paddle-height 2))
+                        paddle-width paddle-height solid-white
+                        0
+                        0
+                        (lambda (b)
+                          (< 90 (ball-direction b) 270))))
+(define p2 (make-paddle
+            'p2
+            (- width (* 2 paddle-width))
+                        (- (/ height 2)
+                           (/ paddle-height 2))
+                        paddle-width paddle-height solid-white
+                        0
+                        0
+                        (lambda (b) (or
+                                    (< 270 (ball-direction b))
+                                    (< (ball-direction b) 90)))))
+
+(define (paddle->sprite name p)
+  (make-sprite name
+               (paddle-x p)
+               (paddle-y p)
+               (paddle-w p)
+               (paddle-h p)))
+
+(define (ball->sprite name b)
+  (let ((r (/ (ball-d b))))
+    (make-sprite name
+                 (ball-x b)
+                 (ball-y b)
+                 1
+                 1)))
+
+(add-sprite! (ball->sprite 'ball b))
+(add-sprite! (paddle->sprite 'p1 p1))
+(add-sprite! (paddle->sprite 'p2 p2))
+(add-sprite! (make-sprite 'upper 0 0 width paddle-width))
+(add-sprite! (make-sprite 'lower 0 (- height paddle-width) width paddle-width))
+(add-sprite! (make-sprite 'left (- (/ paddle-width 2)) 0 paddle-width height))
+(add-sprite! (make-sprite 'right (- width (/ paddle-width 2)) 0 paddle-width height))
+
+
+(define (count-down text delay)
+  (for-each (lambda (t)
+              (clear-screen)
+              (text (/ width 2) (/ height 2) t align: #:center)
+              (show!)
+              (thread-sleep! delay)
+              (clear-screen))
+            text))
+
+(define (new-coords x y dir speed td)
+  (let* ((step (* speed td))
+         (c (* step (cos (* (/ cairo-pi 180) dir))))
+         (a (* step (sin (* (/ cairo-pi 180) dir))))
+         (new-y (- y a))
+         (new-x (+ x c)))
+    (values new-x new-y)))
+
+(define (move-ball! b time-diff)
+  (let-values (((x y) (new-coords
+                       (ball-x b)
+                       (ball-y b)
+                       (ball-direction b)
+                       (ball-speed b)
+                       time-diff)))
+              (ball-x-set! b x)
+              (ball-y-set! b y)))
+
+(define (move-paddle! p dt)
+  (let-values (((x y) (new-coords
+                       (paddle-x p)
+                       (paddle-y p)
+                       (paddle-direction p)
+                       (paddle-speed p)
+                       dt)))
+    (paddle-x-set! p x)
+    (paddle-y-set! p y)))
+
+(define (undo-move-ball b dt)
+  (let-values (((x y) (new-coords
+                       (ball-x b)
+                       (ball-y b)
+                       (other-direction
+                        (ball-direction b))
+                       (ball-speed b)
+                       dt)))
+              (when *print-sprites*
+                (print "Old " b))
+              (ball-x-set! b x)
+              (ball-y-set! b y)
+              (update-sprite! (ball->sprite 'ball b))
+              (when *print-sprites*
+                (print "New sprite " (ball->sprite 'ball b))
+                (print "Undone " b))))
+
+(define (undo-move-paddle p dt)
+  (let-values (((x y) (new-coords
+                       (paddle-x p)
+                       (paddle-y p)
+                       (other-direction
+                        (paddle-direction p))
+                       (paddle-speed p)
+                       dt)))
+              (paddle-x-set! p x)
+              (paddle-y-set! p y)))
+
+(define (update-ball dt)
+  (move-ball! b dt)
+  (update-sprite! (ball->sprite 'ball b))
+  (circle (ball-x b)
+          (ball-y b)
+          (ball-d b)
+          solid-white)
+  (when *draw-sprite-boundaries*
+    (rectangle (ball-x b) (ball-y b) 1 1 '(1 0 0 1))))
+
+(define (update-paddle dt p)
+  (move-paddle! p dt)
+  (update-sprite! (paddle->sprite (paddle-name p) p))
+  (filled-rectangle (paddle-x p)
+                    (paddle-y p)
+                    (paddle-w p)
+                    (paddle-h p)
+                    (paddle-color p)))
+
+(define (run-animations dt)
+  (doto dt
+        (update-paddle p1)
+        (update-paddle p2)
+        (update-ball)))
+
+(define (show-score)
+  (set-font! "Vollkorn Bold" 30 solid-white)
+  (text (/ width 2)
+;            (min 20 (* height 0.05))
+            20
+            (sprintf "~a - ~a"
+                     (first *score*)
+                     (second *score*))
+            align: #:center))
+
+(define (draw-field)
+  (when *draw-sprite-boundaries*
+    (rectangle 0 0 width paddle-width '(1 0 0 1))
+    (rectangle 0 (- height paddle-width) width paddle-width '(1 0 0 1))
+    (rectangle (- (/ paddle-width 2)) 0 paddle-width height '(1 0 0 1))
+    (rectangle (- width (/ paddle-width 2)) 0 paddle-width height '(1 0 0 1)))
+
+  (rectangle paddle-width
+             paddle-width
+             (- width (* 2 paddle-width))
+             (- height (* 2 paddle-width))
+             '(1 1 1 0.3))
+  (draw-line (/ width 2) 0 (/ width 2) height style: #:dashed))
+
+(define (new-ball!)
+  (set-font! "Vollkorn Bold" 50 solid-white)
+
+#;(count-down `(("PLAYER 1 vs PLAYER 2"
+                 ,(sprintf "~a - ~a"
+                           (first *score*)
+                           (second *score*)))) 2)
+  #;(count-down '("READY!" "SET!" "GO!") 0.8)
+  (ball-x-set! b (/ width 2))
+  (ball-y-set! b (/ height 2))
+  (ball-direction-set! b (random-direction)))
+
+(define (handle-event event dt)
+  (when event
+        (cond
+         ((equal? (car event) 'released)
+          (paddle-speed-set! p2 0))
+          ((equal? event '(pressed up))
+           (paddle-speed-set! p2 (* *speed* 0.8))
+           (paddle-direction-set! p2 90))
+          ((equal? event '(pressed down))
+           (paddle-speed-set! p2 (* *speed* 0.8))
+           (paddle-direction-set! p2 270)))
+          ))
+
+(define (handle-collisions cs dt)
+  (let* ((ball-cs (alist-ref 'ball cs))
+         (p1-cs (alist-ref 'p1 cs))
+         (p2-cs (alist-ref 'p2 cs))
+         (score *score*))
+    (when ball-cs
+      (when *print-sprites*
+        (print "time delta " dt)
+        (print cs))
+      (undo-move-ball b dt)
+      (for-each (lambda (c)
+                  (when *print-sprites*
+                    (print (alist-ref c *sprites*))
+                    (print (alist-ref 'ball *sprites*)))
+                  (case c
+                    ((p1 p2)
+                     (ball-direction-set! b (+ (* 2 90)
+                                               360
+                                               (- (ball-direction b)))))
+                    ((upper lower)
+                     (ball-direction-set! b (+ (- (random 10) 5) (- 360 (ball-direction b)))))
+
+                    ((left)
+                     (set! *score* (list (first score)
+                                         (add1 (second score))))
+                     (if (>= (max (first *score*)
+                                 (second *score*))
+                            *max-score-to-win*)
+                         (quit? #t)
+                         (new-ball!)))
+                    ((right)
+                     (set! *score* (list (add1 (first score))
+                                         (second score)))
+                     (if (>= (max (first *score*)
+                                 (second *score*))
+                            *max-score-to-win*)
+                         (quit? #t)
+                         (new-ball!)))))
+                (car ball-cs)))
+    (when p1-cs
+      (undo-move-paddle p1 dt)
+      (case (caar p1-cs)
+        ((upper lower) (paddle-speed-set! p1 0))))
+    (when p2-cs
+    (undo-move-paddle p2 dt)
+      (case (caar p2-cs)
+        ((upper lower) (paddle-speed-set! p2 0))))))
+
+(define (show-last-score)
+  (set-font! "Vollkorn Bold" 50 solid-white)
+  (count-down
+   (list (if (> (first *score*)
+                (second *score*))
+             "PLAYER 1 WINS"
+             "PLAYER 2 WINS")
+         "GAME OVER")
+   1))
+
+(define (move-computer-paddle paddle dir dt)
+  (paddle-direction-set! paddle
+                         (if (eq? dir 'up)
+                             90
+                             270)))
+
+(define (row-of-entry ball) (ball-y ball))
+
+(define (move-computer-player paddle dt)
+  (let ((er (row-of-entry b))
+        (paddle-pos (+ (paddle-y paddle)
+                       (/ (paddle-h paddle)
+                          2))))
+    (paddle-speed-set! paddle 0)
+    (when ((paddle-react? paddle) b)
+      (paddle-speed-set! paddle (* *speed* 0.8))
+      (cond ((< er paddle-pos) (move-computer-paddle paddle 'up dt))
+            ((>= er paddle-pos)(move-computer-paddle paddle 'down dt))))))
+
+(new-doodle width: width height: height title: "Tennis" background: solid-black)
+
+(world-ends (lambda ()
+              (print "Thanks for playing Tennis!")
+              (exit 0)))
+
+(world-inits (lambda ()
+               (set! *score* (list 0 0))
+               (set-font! "Vollkorn Bold" 50 solid-white)
+               (count-down '("T-DOSE tennis" "written in" "CHICKEN Scheme") 2)
+#;
+               (text
+                (/ width 2)
+                (/ height 2)
+                "Want to play yourself (y/N)?"
+                align: #:center)
+                                        ; I need to implement key input here...
+               (count-down '( "READY!" "SET!" "GO!") 1)
+               ))
+
+(world-changes (lambda (event dt escape-continuation)
+;                 (handle-event event dt)
+                 (move-computer-player p1 dt)
+                 (move-computer-player p2 dt)
+                 (clear-screen)
+                 (draw-field)
+;                 (show-score) XXX this should not segfault when enabled...
+                 (run-animations dt)
+                 (handle-collisions (check-for-collisions) dt)
+                 (when (quit?)
+                   (show-last-score)
+                   (thread-sleep! 1)
+                   (escape-continuation #t))))
+
+(run-event-loop run-in-background: (feature? 'csi))