blinking cursor in UI

TODO.FACTOR.txt

@@ -1,5 +1,4 @@
 - reader syntax for arrays, byte arrays, displaced aliens
-- sleep word
 - fix infer hang
 
 + ui:

library/generic/tuple.factor

@@ -31,7 +31,7 @@ namespaces parser sequences strings vectors words ;
 : check-shape ( word slots -- )
     #! If the new list of slots is different from the previous,
     #! forget the old definition.
-    >r "use" get search dup [
+    >r "in" get lookup dup [
         dup "tuple-size" word-prop r> length 2 + =
         [ drop ] [ forget-tuple ] ifte
     ] [

library/test/tuple.factor

@@ -94,3 +94,11 @@ TUPLE: delegate-clone ;
 ! This must be the last test in the file!
 [ "<constructor-test>" ]
 [ "TUPLE: constructor-test ; C: constructor-test ;" eval word word-name ] unit-test
+
+! There was a typo in check-shape; it would unintern the wrong
+! words!
+[ "temporary-1" ]
+[
+    "IN: temporary-1 SYMBOL: foobar IN: temporary TUPLE: foobar ;" eval
+    "foobar" [ "temporary-1" "temporary" ] search word-vocabulary
+] unit-test

library/ui/editors.factor

@@ -1,8 +1,28 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel line-editor math matrices namespaces
-sdl sequences strings styles vectors ;
+USING: generic kernel math matrices namespaces sdl sequences
+strings styles vectors ;
+
+! A blinking caret
+TUPLE: caret ;
+
+C: caret ( -- caret )
+    <plain-gadget> over set-delegate
+    dup red background set-paint-prop
+    500 over set-gadget-framerate ;
+
+: toggle-visible ( gadget -- )
+    dup gadget-visible? not over set-gadget-visible?
+    relayout ;
+
+M: caret tick* ( ms caret -- ) nip toggle-visible ;
+
+: add-caret ( caret parent -- ) dupd add-gadget add-timer ;
+
+: unparent-caret ( caret -- ) dup remove-timer unparent ;
+
+USE: line-editor
 
 ! An editor gadget wraps a line editor object and passes
 ! gestures to the line editor.
@@ -22,10 +42,10 @@ TUPLE: editor line caret ;
     [ set-line-text ] with-editor ;
 
 : focus-editor ( editor -- )
-    dup editor-caret swap add-gadget ;
+    dup editor-caret swap add-caret ;
 
 : unfocus-editor ( editor -- )
-    editor-caret unparent ;
+    editor-caret unparent-caret ;
 
 : run-char-widths ( font str -- wlist )
     #! List of x co-ordinates of each character.
@@ -58,9 +78,6 @@ TUPLE: editor line caret ;
         [[ [ "END" ] [ [ end ] with-editor ] ]]
     ] swap add-actions ;
 
-: <caret> ( -- caret )
-    <plain-gadget> dup red background set-paint-prop ;
-
 C: editor ( text -- )
     <gadget> over set-delegate
     [ <line-editor> swap set-editor-line ] keep

library/ui/gadgets.factor

@@ -33,7 +33,7 @@ M: rectangle inside? ( loc rect -- ? )
 ! A gadget is a rectangle, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent.
 TUPLE: gadget
-    paint gestures visible? relayout? root?
+    paint gestures framerate visible? relayout? root?
     parent children ;
 
 : gadget-child gadget-children first ;

library/ui/hierarchy.factor

@@ -6,8 +6,7 @@ sequences vectors ;
 
 : remove-gadget ( gadget parent -- )
     [ 2dup gadget-children remq swap set-gadget-children ] keep
-    relayout
-    f swap set-gadget-parent ;
+    relayout f swap set-gadget-parent ;
 
 : unparent ( gadget -- )
     [

library/ui/load.factor

@@ -10,6 +10,7 @@ USING: kernel parser sequences io ;
     "/library/ui/borders.factor"
     "/library/ui/frames.factor"
     "/library/ui/world.factor"
+    "/library/ui/timer.factor"
     "/library/ui/hand.factor"
     "/library/ui/labels.factor"
     "/library/ui/buttons.factor"

library/ui/timer.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: hashtables kernel math namespaces sequences ;
+
+TUPLE: timer gadget last ;
+
+C: timer ( gadget -- timer )
+    [ set-timer-gadget ] keep
+    millis over set-timer-last ;
+
+GENERIC: tick* ( ms gadget -- )
+
+: next-time ( timer -- ms )
+    dup timer-gadget gadget-framerate swap timer-last + ;
+
+: advance-timer ( ms timer -- delay )
+    #! Outputs the time since the last firing.
+    [ timer-last - 0 max ] 2keep set-timer-last ;
+
+: do-timer ( ms timer -- )
+    #! Takes current time, and a timer. If the timer is set to
+    #! fire, calls its callback.
+    dup next-time pick <=
+    [ [ advance-timer ] keep timer-gadget tick* ] [ 2drop ] ifte ;
+
+: timers ( -- hash ) world get world-timers ;
+
+: add-timer ( gadget -- ) [ <timer> ] keep timers set-hash ;
+
+: remove-timer ( gadget -- ) timers remove-hash ;
+
+: do-timers ( -- )
+    millis timers hash-values [ do-timer ] each-with ;
+
+M: gadget tick* ( ms gadget -- ) 2drop ;

library/ui/world.factor

@@ -9,15 +9,17 @@ vectors ;
 ! gadgets are contained in. The current world is stored in the
 ! world variable. The invalid slot is a list of gadgets that
 ! need to be layout.
-TUPLE: world running? hand glass invalid ;
+TUPLE: world running? hand glass invalid timers ;
 
 DEFER: <hand>
 DEFER: update-hand
+DEFER: do-timers
 
 C: world ( -- world )
     f <stack> over set-delegate
     t over set-gadget-root?
-    dup <hand> over set-world-hand ;
+    dup <hand> over set-world-hand
+    <namespace> over set-world-timers ;
 
 : add-invalid ( gadget -- )
     world get [ world-invalid cons ] keep set-world-invalid ;
@@ -65,7 +67,7 @@ DEFER: handle-event
     next-event [
         handle-event run-world
     ] [
-        drop world-step
+        drop world-step do-timers
         world get world-running? [ 10 sleep run-world ] when
     ] ifte ;