extra/rosetta-code/animate-pendulum/animate-pendulum.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays calendar colors kernel locals math
   5 math.constants math.functions math.rectangles math.vectors
   6 opengl sequences system timers ui ui.gadgets ui.render ;
   7
   8 IN: rosetta-code.animate-pendulum
   9
  10 ! http://rosettacode.org/wiki/Animate_a_pendulum
  11
  12 ! One good way of making an animation is by simulating a
  13 ! physical system and illustrating the variables in that system
  14 ! using a dynamically changing graphical display. The classic such
  15 ! physical system is a simple gravity pendulum.
  16
  17 ! For this task, create a simple physical model of a pendulum
  18 ! and animate it.
  19
  20 CONSTANT: g 9.81
  21 CONSTANT: l 20
  22 CONSTANT: theta0 0.5
  23
  24 : current-time ( -- time ) nano-count -9 10^ * ;
  25
  26 : T0 ( -- T0 ) 2 pi l g / sqrt * * ;
  27 : omega0 ( -- omega0 ) 2 pi * T0 / ;
  28 : theta ( -- theta ) current-time omega0 * cos theta0 * ;
  29
  30 : relative-xy ( theta l -- xy )
  31     [ [ sin ] [ cos ] bi ]
  32     [ [ * ] curry ] bi* bi@ 2array ;
  33 : theta-to-xy ( origin theta l -- xy ) relative-xy v+ ;
  34
  35 TUPLE: pendulum-gadget < gadget alarm ;
  36
  37 : O ( gadget -- origin ) rect-bounds [ drop ] [ first 2 / ] bi* 0 2array ;
  38 : window-l ( gadget -- l ) rect-bounds [ drop ] [ second ] bi* ;
  39 : gadget-xy ( gadget -- xy ) [ O ] [ drop theta ] [ window-l ] tri theta-to-xy ;
  40
  41 M: pendulum-gadget draw-gadget*
  42     COLOR: black gl-color
  43     [ O ] [ gadget-xy ] bi gl-line ;
  44
  45 M: pendulum-gadget graft* ( gadget -- )
  46     [ call-next-method ]
  47     [
  48         dup [ relayout-1 ] curry
  49         20 milliseconds every >>alarm drop
  50     ] bi ;
  51
  52 M: pendulum-gadget ungraft*
  53     [ alarm>> stop-timer ] [ call-next-method ] bi ;
  54
  55 : <pendulum-gadget> ( -- gadget )
  56     pendulum-gadget new
  57     { 500 500 } >>pref-dim ;
  58
  59 MAIN-WINDOW: pendulum-main
  60     { { title "pendulum" } }
  61     <pendulum-gadget> >>gadgets ;