diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1cbcc78c56..666c66bd31 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,4 @@ - reader syntax for arrays, byte arrays, displaced aliens -- sleep word - fix infer hang + ui: diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 321c93d6d8..8f2de62e04 100644 --- a/library/generic/tuple.factor +++ b/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 ] [ diff --git a/library/test/tuple.factor b/library/test/tuple.factor index af57abebce..f220de5303 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -94,3 +94,11 @@ TUPLE: delegate-clone ; ! This must be the last test in the file! [ "" ] [ "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 diff --git a/library/ui/editors.factor b/library/ui/editors.factor index 5c0f5ac07d..830207a846 100644 --- a/library/ui/editors.factor +++ b/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 ) + 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 ) - dup red background set-paint-prop ; - C: editor ( text -- ) over set-delegate [ swap set-editor-line ] keep diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9a9f063303..d7f9c1abdb 100644 --- a/library/ui/gadgets.factor +++ b/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 ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index e57bf5717c..776d4169de 100644 --- a/library/ui/hierarchy.factor +++ b/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 -- ) [ diff --git a/library/ui/load.factor b/library/ui/load.factor index b996162deb..706d38a22f 100644 --- a/library/ui/load.factor +++ b/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" diff --git a/library/ui/timer.factor b/library/ui/timer.factor new file mode 100644 index 0000000000..766357b4e2 --- /dev/null +++ b/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 -- ) [ ] 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 ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 68c49436a8..785a9920a3 100644 --- a/library/ui/world.factor +++ b/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: DEFER: update-hand +DEFER: do-timers C: world ( -- world ) f over set-delegate t over set-gadget-root? - dup over set-world-hand ; + dup over set-world-hand + 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 ;