jamshred fixes, but still has an endless recursion bug

[factor.git] / extra / jamshred / jamshred.factor

diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index d0b74417d188c3b9b50f40cb1c8b7236c02edaef..49624e29470bb07f780c2433953d4bbcb618c7e3 100644 (file)
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
 IN: jamshred
 
 TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
 
 : <jamshred-gadget> ( jamshred -- gadget )
-    jamshred-gadget new-gadget swap >>jamshred ;
+    jamshred-gadget new swap >>jamshred ;
 
 : default-width ( -- x ) 800 ;
 : default-height ( -- y ) 600 ;
@@ -15,7 +15,7 @@ M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
 
 M: jamshred-gadget draw-gadget* ( gadget -- )
-    [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
+    [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
 
 : jamshred-loop ( gadget -- )
     dup jamshred>> quit>> [
@@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
     ] [
         [ jamshred>> jamshred-update ]
         [ relayout-1 ]
-        [ 10 milliseconds sleep yield jamshred-loop ] tri
+        [ 100 milliseconds sleep jamshred-loop ] tri 
     ] if ;
 
 : fullscreen ( gadget -- )
@@ -36,10 +36,11 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
     [ fullscreen? not ] keep set-fullscreen* ;
 
 M: jamshred-gadget graft* ( gadget -- )
-    [ jamshred-loop ] curry in-thread ;
+    [ find-gl-context init-graphics ]
+    [ [ jamshred-loop ] curry in-thread ] bi ;
 
 M: jamshred-gadget ungraft* ( gadget -- )
-    jamshred>> t swap (>>quit) ;
+    dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
 
 : jamshred-restart ( jamshred-gadget -- )
     <jamshred> >>jamshred drop ;
@@ -49,16 +50,15 @@ M: jamshred-gadget ungraft* ( gadget -- )
 
 : x>radians ( x gadget -- theta )
     #! translate motion of x pixels to an angle
-    rect-dim first pix>radians neg ;
+    dim>> first pix>radians neg ;
 
 : y>radians ( y gadget -- theta )
     #! translate motion of y pixels to an angle
-    rect-dim second pix>radians ;
+    dim>> second pix>radians ;
 
 : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
-    over jamshred>> >r
-    [ first swap x>radians ] 2keep second swap y>radians
-    r> mouse-moved ;
+    dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+    rot jamshred>> mouse-moved ;
     
 : handle-mouse-motion ( jamshred-gadget -- )
     hand-loc get [
@@ -84,11 +84,11 @@ jamshred-gadget H{
     { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
     { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
     { T{ key-down f f "q" } [ quit ] }
-    { T{ motion } [ handle-mouse-motion ] }
-    { T{ mouse-scroll } [ handle-mouse-scroll ] }
+    { motion [ handle-mouse-motion ] }
+    { mouse-scroll [ handle-mouse-scroll ] }
 } set-gestures
 
-: jamshred-window ( -- gadget )
-    [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+: jamshred-window ( -- )
+    [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
 
 MAIN: jamshred-window