test/roots.lisp

   1 (in-package :as3-compiler)
   2 ;;; sample from old version. works but needs more refactoring
   3
   4 (define-special %to-double (a)
   5   `(,@(scompile a)
   6     (:convert-double)))
   7
   8 (define-special %to-integer (a)
   9   `(,@(scompile a)
  10     (:convert-integer)))
  11
  12 (with-open-file (s "/tmp/roots.swf"
  13                    :direction :output
  14                               :element-type '(unsigned-byte 8)
  15                               :if-exists :supersede)
  16   (with-compilation-to-stream s ("frame1" `((0 "testClass")))
  17
  18     (def-swf-class :test-class "test-class" flash.display::sprite ()
  19                    (()
  20                     (main this)))
  21
  22     (swf-defmemfun random-range (a b)
  23       (+ a (floor (random (- b a)))))
  24
  25     #+nil(swf-defmemfun radians (a)
  26            (/ (* a flash::math.PI) 180.0))
  27     (swf-defmemfun radians (a)
  28       (/ (* a #.pi) 180.0))
  29
  30     (swf-defmemfun i255 (a)
  31       (flash::Math.max (flash::Math.min (floor (* a 256)) 255) 0))
  32
  33     (swf-defmemfun rgb (r g b)
  34       (+ (* (i255 r) 65536) (* (i255 g) 256) (i255 b)))
  35
  36     (swf-defmemfun rgba (r g b a)
  37       (+ (* (i255 a) 65536 256) (rgb r g b)))
  38
  39     (swf-defmemfun main (arg)
  40       (let ((foo (%new flash.text::Text-Field 0))
  41             (canvas (%new flash.display::Sprite 0)))
  42         (%set-property foo :width 200)
  43         (%set-property foo :auto-size "left")
  44         (%set-property foo :text-color (rgb 0.2 0.9 0.2 ))
  45         (%set-property foo :word-wrap :true)
  46         (%set-property foo :background :true)
  47         (%set-property foo :background-color (rgba 0.1 0.1 0.1 0.1))
  48         (let ((str "abc..."))
  49           (%set-property foo :text (+ str (%call-property (%array 1 2 3) :to-string))))
  50         (:add-child arg canvas)
  51         (:add-child arg foo)
  52         (%set-property this :canvas canvas)
  53         (frame :null)
  54         #+nil(:add-event-listener arg "enterFrame" (%get-lex :frame))
  55         (:add-event-listener canvas "click" (%asm (:get-lex frame)))))
  56
  57     (swf-defmacro with-fill (gfx (color alpha &key line-style) &body body)
  58       `(progn
  59          ,@(when line-style
  60                  `((:line-style ,gfx ,@line-style)))
  61          (:begin-fill ,gfx ,color ,alpha)
  62          ,@body
  63          (:end-fill ,gfx)))
  64
  65     (swf-defmemfun frame (evt)
  66       (let* ((canvas (%get-property this :canvas))
  67              (gfx (:graphics canvas))
  68              (matrix (%new flash.geom::Matrix 0)))
  69
  70         (%set-property canvas :opaque-background #x0d0f00)
  71         (:clear gfx)
  72         (with-fill gfx (#x202600  0.5)
  73                    (:draw-rect gfx 0 0 400 300 ))
  74         (:create-gradient-box matrix
  75                               400 300 0 0 0)
  76         (:begin-gradient-fill gfx "radial"
  77                               (%array #x202600 #x0d0f00) ;; colors
  78                               (%array 1 1)               ;; alpha
  79                               (%array 0 255)             ;; ratios
  80                               matrix)
  81         (:draw-rect gfx 0 0 400 300 )
  82         (:end-fill gfx)
  83         (root canvas 200 150 (random 360) 7 1.0 0.005 )))
  84
  85     (swf-defmemfun root (canvas x y angle depth alpha decay)
  86       (%set-local alpha (%to-double alpha))
  87       (%set-local x (%to-double x))
  88       (%set-local y (%to-double y))
  89       (let* ((s (* depth 0.5))
  90              (w (* s 6.0))
  91              (line-size (* s 0.5))
  92              (gfx (:graphics canvas )))
  93         (dotimes (i (%to-integer (* depth (random-range 10 20))))
  94           (let* ((v (/ depth 5.0))
  95                  (color (rgb  (- 0.8 (* v 0.25))
  96                               0.8
  97                               (- 0.8 v))))
  98             (%set-local alpha (flash::Math.max 0.0 (- alpha (* i decay))))
  99
 100             ;; stop if alpha gets below 1/256 or so
 101             (when (> alpha 0.004)
 102               (%set-local angle (+ angle (random-range -60 60)))
 103               (let ((dx (+ x (* (cos (radians angle)) w)))
 104                     (dy (+ y (* (sin (radians angle)) w))))
 105
 106                 ;; drop shadow
 107                 (with-fill gfx (0 (* alpha 0.6) :line-style (:nan 0 alpha))
 108                            (:draw-circle gfx (+ x s 1) (1- (+ y s)) (/ w 3)))
 109
 110                 ;; line segment to next position:
 111                 (with-fill gfx (color (* alpha 0.6)
 112                                       :line-style (line-size color alpha))
 113                            (:move-to gfx x y)
 114                            (:line-to gfx dx dy))
 115
 116                 ;; filled circle
 117                 (with-fill gfx (color (* alpha 0.5)
 118                                       :line-style ((* 0.5 line-size)
 119                                                    color alpha))
 120                            (:draw-circle gfx x y (/ w 4)))
 121
 122                 (when (and (> depth 0) (> (random 1.0) 0.85))
 123                   (root canvas x y (+ angle (random-range -60 60))
 124                         (1- depth) alpha decay))
 125                 (%set-local x (%to-double dx))
 126                 (%set-local y (%to-double dy))))))
 127
 128         (when (and (> depth 0) (> (random 1.0) 0.7))
 129           (root canvas x y angle (1- depth) alpha decay))))))