test/roots.lisp

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