guiserver/pinballs-demo.lsp

   1 #!/usr/bin/newlisp
   2 ;; pinballs-demo.lsp - demos animations and gs:check-event function
   3
   4 ;; GS 1.05+
   5 ;; v0.1
   6 ;;
   7 ;; PinBalls, Cormullion wanted collision, Cormullion got collision ;-)
   8 ;;
   9 ;;
  10 ;; There are different ways to detect collisions with figures, here is an
  11 ;; example that uses a circle.
  12 ;;
  13 ;; In the current GS there is not x,y tag detection nor the option to draw
  14 ;; a circle using floats. So you have to be inventive ;-)
  15 ;;
  16 ;; This example uses gs:draw-circle and stores a imagionary boundry in BOUNDS
  17 ;; per circle/BALL. These are the collision boundry's.
  18 ;;
  19 ;; The calculation is done on the edge of the BALL calls CIRCLE-DOTS. The
  20 ;; more CIRCLE-DOTS the more detection. The more BALLS's the more calculations.
  21 ;;
  22 ;; you can change the quoted line in the code that draws its own circle!
  23 ;; if you use that you will see that GS is unable to do floats because the
  24 ;; BALL looks a little eaten. (takes more performance too!)
  25 ;;
  26 ;; Change the RADIUS to change to size of the BALL.
  27 ;;
  28 ;; BALL collision is done in 4 quadrants, this is easier then calculate them
  29 ;; on every 360 dgr. Here we take a default of 4 x 4 for speed angle.
  30 ;;
  31 ;; behaviour can change per system, if you run GS with your webbrowser open
  32 ;; (that uses JAVA or flash) you could notice stottering of the applet.
  33 ;;
  34 ;; Enjoy, Norman. (c) 2007
  35 ;; (some changes for addition to demos by L.M.)
  36
  37 (set-locale "C")
  38 (seed ((now) 6))
  39 (load (append (env "NEWLISPDIR") "/guiserver.lsp"))
  40
  41 (gs:init)
  42 (gs:get-screen)
  43 (set 'ww 500 'wh 500 'sw (gs:screen 0) 'sh (gs:screen 1))
  44 (gs:frame 'F  (- (div sw 2) (div ww 2)) (- (div sh 2) (div wh 2)) ww (+ wh 20) "PinBalls")
  45 (gs:canvas 'C)
  46 (gs:set-resizable 'F nil)
  47 (gs:set-font 'C "Monospaced" 8 "bold")
  48 (gs:set-background 'C gs:black)
  49 (gs:add-to 'F 'C)
  50 (gs:set-visible 'F true)
  51
  52 ;; set variables
  53 (set 'RADIUS 40 'CIRCLE-DOTS 256 'BALLS 5)
  54 (define (rcolor) (list (random) (random) (random)))
  55 (gs:set-stroke 3)
  56
  57 ;; updates the current circle bounds
  58 (define (update-circle c x y, r)
  59 (set (sym c) '())
  60  (dotimes (r CIRCLE-DOTS)
  61   (push (list (+ x (mul RADIUS (cos r))) (+ y (mul RADIUS (sin r)))) (eval (sym c)) -1))
  62    (push (eval (sym c)) BOUNDS -1))
  63
  64 ;; needs to draws my own circle
  65 (dotimes (t BALLS)
  66 (set 'x (+ RADIUS (rand 400)) 'y (+ RADIUS (rand 400)))
  67  (update-circle (string "O" t) x y)
  68     (gs:draw-circle (string "C" t) x y RADIUS (rcolor))
  69     (gs:draw-circle (string "C" t) x y ( - RADIUS 5) (rcolor))
  70     (gs:draw-text (string "C" t) (string t) (- x 1) y gs:white)
  71     (push (list (string "C" t) x y 0 3 (string "O" t)) CIRCLE -1))
  72
  73 ;; define pseudo hit-angle action
  74 (set 'M '(-3 -2 -1) 'P (map abs M))
  75 (define (flip) (apply amb (append M P)))
  76 (define (flap) (apply amb M))
  77 (define (flop) (apply amb P))
  78
  79 (while (gs:check-event 10000)
  80         (dolist (L CIRCLE)
  81                 (set 'tx (L 1))
  82                 (set 'ty (L 2))
  83                 (set  'X (L 3))
  84                 (set  'Y (L 4))
  85                 (set  'B (BOUNDS 0))
  86
  87                 ;; check wall bounds
  88                 (and (>= tx (- ww  RADIUS )) (set 'X (flap) 'Y (flip)) )
  89                 (and (<= tx        RADIUS )  (set 'X (flop) 'Y (flip)) )
  90                 (and (>= ty (- wh  RADIUS )) (set 'X (flip) 'Y (flap)) )
  91                 (and (<= ty        RADIUS )  (set 'X (flip) 'Y (flop)) )
  92
  93                 ;; with every movement update the circle boundary
  94                 (pop BOUNDS)
  95
  96                 (dolist (BB BOUNDS)
  97                 (and (intersect B BB)
  98                                 (or (and (<= ((BB 0) 0) tx) (<= ((BB 0) 1) ty) (set 'X  4 'Y  4 ))
  99                                         (and (>= ((BB 0) 0) tx) (<= ((BB 0) 1) ty) (set 'X -4 'Y  4 ))
 100                                         (and (<= ((BB 0) 0) tx) (>= ((BB 0) 1) ty) (set 'X  4 'Y -4 ))
 101                                         (and (>= ((BB 0) 0) tx) (>= ((BB 0) 1) ty) (set 'X -4 'Y -4 ))
 102                                 )
 103                         )
 104                 )
 105
 106                 (gs:move-tag (L 0) X Y 0 nil)
 107                 (update-circle (L 5) tx ty)
 108
 109                 ;; update the "per" CIRCLE data
 110                 (replace-assoc (L 0) CIRCLE (list (L 0) (inc 'tx X) (inc 'ty Y) X Y (L 5)))
 111                 (gs:update)
 112         )
 113 )
 114
 115 (exit)
 116