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