extra/jamshred/jamshred.factor

   1 ! Copyright (C) 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar jamshred.game jamshred.gl
   4 jamshred.player kernel math math.constants math.vectors
   5 namespaces sequences threads ui ui.gadgets ui.gadgets.worlds
   6 ui.gestures ui.render ;
   7 IN: jamshred
   8
   9 TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
  10
  11 : <jamshred-gadget> ( jamshred -- gadget )
  12     jamshred-gadget new swap >>jamshred ;
  13
  14 CONSTANT: default-width 800
  15 CONSTANT: default-height 600
  16
  17 M: jamshred-gadget pref-dim*
  18     drop default-width default-height 2array ;
  19
  20 M: jamshred-gadget draw-gadget* ( gadget -- )
  21     [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
  22
  23 : jamshred-loop ( gadget -- )
  24     dup jamshred>> quit>> [
  25         drop
  26     ] [
  27         [ jamshred>> jamshred-update ]
  28         [ relayout-1 ]
  29         [ 100 milliseconds sleep jamshred-loop ] tri
  30     ] if ;
  31
  32 M: jamshred-gadget graft* ( gadget -- )
  33     [ find-gl-context init-graphics ]
  34     [ [ jamshred-loop ] curry in-thread ] bi ;
  35
  36 M: jamshred-gadget ungraft* ( gadget -- )
  37     dup find-gl-context cleanup-graphics jamshred>> t swap quit<< ;
  38
  39 : jamshred-restart ( jamshred-gadget -- )
  40     <jamshred> >>jamshred drop ;
  41
  42 : pix>radians ( n m -- theta )
  43     / pi 4 * * ; ! 2 / / pi 2 * * ;
  44
  45 : x>radians ( x gadget -- theta )
  46     ! translate motion of x pixels to an angle
  47     dim>> first pix>radians neg ;
  48
  49 : y>radians ( y gadget -- theta )
  50     ! translate motion of y pixels to an angle
  51     dim>> second pix>radians ;
  52
  53 : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
  54     dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
  55     rot jamshred>> mouse-moved ;
  56
  57 : handle-mouse-motion ( jamshred-gadget -- )
  58     hand-loc get [
  59         over last-hand-loc>> [
  60             v- (handle-mouse-motion)
  61         ] [ 2drop ] if*
  62     ] 2keep >>last-hand-loc drop ;
  63
  64 : handle-mouse-scroll ( jamshred-gadget -- )
  65     jamshred>> scroll-direction get
  66     [ first mouse-scroll-x ]
  67     [ second mouse-scroll-y ] 2bi ;
  68
  69 : quit ( gadget -- )
  70     [ f set-fullscreen ] [ close-window ] bi ;
  71
  72 jamshred-gadget H{
  73     { T{ key-down f f "r" } [ jamshred-restart ] }
  74     { T{ key-down f f " " } [ jamshred>> toggle-running ] }
  75     { T{ key-down f f "f" } [ toggle-fullscreen ] }
  76     { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
  77     { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
  78     { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
  79     { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
  80     { T{ key-down f f "ESC" } [ quit ] }
  81     { T{ key-down f f "q" } [ quit ] }
  82     { motion [ handle-mouse-motion ] }
  83     { mouse-scroll [ handle-mouse-scroll ] }
  84 } set-gestures
  85
  86 MAIN-WINDOW: jamshred-window { { title "Jamshred" } }
  87     <jamshred> <jamshred-gadget> >>gadgets ;