test/roots.lisp

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