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

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