fixed compiler; UI work

TODO.FACTOR.txt

@@ -8,6 +8,7 @@
 - goal: to compile hash* optimally
 - type check/not-check entry points for compiled words
 - getenv/setenv: if literal arg, compile as a load/store
+- empty ifte: wrong input type.
 
 + oop:
 
@@ -40,6 +41,7 @@
 - completion in the listener
 - special completion for USE:/IN:
 - support USING:
+- command to prettyprint word def at caret, or selection
 
 + i/o:
 

library/bootstrap/boot-stage2.factor

@@ -108,6 +108,9 @@ USING: kernel lists parser stdio words namespaces ;
 
     "/library/ui/line-editor.factor"
     "/library/ui/console.factor"
+    "/library/ui/shapes.factor"
+    "/library/ui/paint.factor"
+    "/library/ui/gadgets.factor"
 
     "/library/bootstrap/image.factor"
 

library/compiler/alien.factor

@@ -96,10 +96,10 @@ SYMBOL: alien-parameters
 
 : infer-alien ( -- )
     [ object object object object ] ensure-d
-    dataflow-drop, pop-d value-literal
+    dataflow-drop, pop-d literal-value
-    dataflow-drop, pop-d value-literal >r
+    dataflow-drop, pop-d literal-value >r
-    dataflow-drop, pop-d value-literal
+    dataflow-drop, pop-d literal-value
-    dataflow-drop, pop-d value-literal -rot
+    dataflow-drop, pop-d literal-value -rot
     r> swap alien-node ;
 
 : box-parameter

library/generic/tuple.factor

@@ -98,6 +98,30 @@ kernel-internals math hashtables errors ;
     >r unit [ car tuple-dispatch call ] cons tuple r>
     set-vtable ;
 
+M: tuple clone ( tuple -- tuple )
+    dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
+
+: tuple>list ( tuple -- list )
+    dup array-capacity swap array>list ;
+
+M: tuple = ( obj tuple -- ? )
+    over tuple? [
+        over class over class = [
+            swap tuple>list swap tuple>list =
+        ] [
+            2drop f
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+M: tuple hashcode ( vec -- n )
+    dup array-capacity 1 number= [
+        drop 0
+    ] [
+        1 swap array-nth hashcode
+    ] ifte ;
+
 M: tuple class ( obj -- class ) 2 slot ;
 
 tuple [

library/inference/branches.factor

@@ -113,7 +113,7 @@ SYMBOL: cloned
         uncons propagate-type
         dup value-recursion recursive-state set
         copy-inference
-        value-literal dup infer-quot
+        literal-value dup infer-quot
         #values values-node
         handle-terminator
     ] extend ;
@@ -177,7 +177,7 @@ SYMBOL: cloned
     dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
     gensym [
         dup value-recursion recursive-state set
-        value-literal infer-quot
+        literal-value infer-quot
     ] (with-block) drop ;
 
 : dynamic-ifte ( true false -- )
@@ -204,7 +204,7 @@ SYMBOL: cloned
 \ ifte [ infer-ifte ] "infer" set-word-property
 
 : vtable>list ( value -- list )
-    dup value-recursion swap value-literal vector>list
+    dup value-recursion swap literal-value vector>list
     [ over <literal> ] map nip ;
 
 USE: kernel-internals

library/inference/inference.factor

@@ -63,20 +63,16 @@ SYMBOL: recursive-state
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class-and ( class value -- )
 
-! A value has the following slots in addition to those relating
+TUPLE: value class type-prop recursion ;
-! to generics above:
 
-TUPLE: value literal class type-prop recursion ;
+C: value ( recursion -- value )
-C: value ;
+    [ set-value-recursion ] keep ;
 
 TUPLE: computed delegate ;
 
 C: computed ( class -- value )
-    <value> over set-computed-delegate
+    swap recursive-state get <value> [ set-value-class ] keep
-    [ set-value-class ] keep ;
+    over set-computed-delegate ;
-
-M: computed value-literal ( value -- obj )
-    "Cannot use a computed value literally." throw ;
 
 M: computed value= ( literal value -- ? )
     2drop f ;
@@ -84,15 +80,17 @@ M: computed value= ( literal value -- ? )
 M: computed value-class-and ( class value -- )
     [ value-class class-and ] keep set-value-class ;
 
-TUPLE: literal delegate ;
+TUPLE: literal value delegate ;
 
 C: literal ( obj rstate -- value )
-    <value> over set-literal-delegate
+    [
-    [ set-value-recursion ] keep
+        >r <value> [ >r dup class r> set-value-class ] keep
-    [ set-value-literal ] keep ;
+        r> set-literal-delegate
+    ] keep
+    [ set-literal-value ] keep ;
 
 M: literal value= ( literal value -- ? )
-    value-literal = ;
+    literal-value = ;
 
 M: literal value-class-and ( class value -- )
     value-class class-and drop ;

library/inference/types.factor

@@ -29,7 +29,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
 
 ! \ slot [
 !     [ object fixnum ] ensure-d
-!     dataflow-drop, pop-d value-literal
+!     dataflow-drop, pop-d literal-value
 !     peek-d value-class builtin-supertypes dup length 1 = [
 !         cons \ slot [ [ object ] [ object ] ] (consume/produce)
 !     ] [
@@ -48,7 +48,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
         1 0 node-inputs
         [ object ] consume-d
         [ fixnum ] produce-d
-        r> peek-d value-type-prop
+        r> peek-d set-value-type-prop
         1 0 node-outputs
     ] bind
 ] "infer" set-word-property

library/inference/words.factor

@@ -87,23 +87,6 @@ M: promise (apply-word) ( word -- )
 M: symbol (apply-word) ( word -- )
     apply-literal ;
 
-: current-word ( -- word )
-    #! Push word we're currently inferring effect of.
-    recursive-state get car car ;
-
-: check-recursion ( word -- )
-    #! If at the location of the recursive call, we're taking
-    #! more items from the stack than producing, we have a
-    #! diverging recursion. Note that this check is not done for
-    #! mutually-recursive words. Generally they should be
-    #! avoided.
-    current-word = [
-        d-in get vector-length
-        meta-d get vector-length > [
-            current-word word-name " diverges." cat2 throw
-        ] when
-    ] when ;
-
 : with-recursion ( quot -- )
     [
         inferring-base-case inc
@@ -143,7 +126,7 @@ M: symbol (apply-word) ( word -- )
 : apply-word ( word -- )
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get assoc [
-        dup check-recursion recursive-word
+        recursive-word
     ] [
         dup "infer-effect" word-property [
             apply-effect
@@ -158,7 +141,7 @@ M: symbol (apply-word) ( word -- )
     gensym dup [
         drop pop-d dup
         value-recursion recursive-state set
-        value-literal infer-quot
+        literal-value infer-quot
     ] with-block drop ;
 
 \ call [ infer-call ] "infer" set-word-property

library/lists.factor

@@ -11,6 +11,9 @@ IN: lists USING: generic kernel math ;
 : 3list ( a b c -- [ a b c ] )
     2list cons ;
 
+: 3unlist ( [ a b c ] -- a b c )
+    uncons uncons car ;
+
 : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
     over [ >r uncons r> append cons ] [ nip ] ifte ;
 

library/sdl/sdl-utils.factor

@@ -57,7 +57,7 @@ SYMBOL: surface
     #! Set up SDL graphics and call the quotation.
     [ >r init-screen r> call SDL_Quit ] with-scope ; inline
 
-: rgb ( r g b a -- n )
+: rgb ( r g b -- n )
     255
     swap 8 shift bitor
     swap 16 shift bitor

library/test/test.factor

@@ -67,6 +67,7 @@ USE: unparser
         "strings"
         "namespaces"
         "generic"
+        "tuple"
         "files"
         "parser"
         "parse-number"

library/test/tuple.factor

@@ -0,0 +1,18 @@
+IN: scratchpad
+USING: generic kernel test math ;
+
+TUPLE: rect x y w h ;
+C: rect
+    [ set-rect-h ] keep
+    [ set-rect-w ] keep
+    [ set-rect-y ] keep
+    [ set-rect-x ] keep ;
+    
+: move ( x rect -- )
+    [ rect-x + ] keep set-rect-x ;
+
+[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
+
+[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
+
+

library/ui/gadgets.factor

@@ -0,0 +1,82 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic hashtables kernel lists namespaces ;
+
+! Gadget protocol.
+GENERIC: pick-up ( point gadget -- gadget )
+
+! A gadget is a shape together with paint, and a reference to
+! the gadget's parent. A gadget delegates to its shape.
+TUPLE: gadget paint parent delegate ;
+
+C: gadget ( shape -- gadget )
+    [ set-gadget-delegate ] keep
+    [ <namespace> swap set-gadget-paint ] keep ;
+
+: paint-property ( gadget key -- value )
+    swap gadget-paint hash ;
+
+: set-paint-property ( gadget value key -- )
+    rot gadget-paint set-hash ;
+
+: with-gadget ( gadget quot -- )
+    #! All drawing done inside the quotation is done with the
+    #! gadget's paint. If the gadget does not have any custom
+    #! paint, just call the quotation.
+    >r gadget-paint r> bind ;
+
+M: gadget draw ( gadget -- )
+    dup [ gadget-delegate draw ] with-gadget ;
+
+M: gadget pick-up tuck inside? [ drop f ] unless ;
+
+! An invisible gadget.
+WRAPPER: ghost
+M: ghost draw drop ;
+M: ghost pick-up 2drop f ;
+
+! A box is a gadget holding other gadgets.
+TUPLE: box contents delegate ;
+
+C: box ( gadget -- box )
+    [ set-box-delegate ] keep ;
+
+M: general-list draw ( list -- )
+    [ draw ] each ;
+
+M: box draw ( box -- )
+    dup [
+        dup [
+            dup box-contents draw
+            box-delegate draw
+        ] with-gadget
+    ] with-translation ;
+
+M: general-list pick-up ( point list -- gadget )
+    dup [
+        2dup car pick-up dup [
+            2nip
+        ] [
+            drop cdr pick-up
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+M: box pick-up ( point box -- )
+    #! The logic is thus. If the point is definately outside the
+    #! box, return f. Otherwise, see if the point is contained
+    #! in any subgadget. If not, see if it is contained in the
+    #! box delegate.
+    dup [
+        2dup gadget-delegate inside? [
+            2dup box-contents pick-up dup [
+                2nip
+            ] [
+                drop box-delegate pick-up
+            ] ifte
+        ] [
+            2drop f
+        ] ifte
+    ] with-translation ;

library/ui/paint.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl sdl-gfx ;
+
+! The painting protocol. Painting is controlled by various
+! dynamically-scoped variables.
+
+! "Paint" is a namespace containing some or all of these values.
+SYMBOL: color  ! a list of three integers, 0..255.
+SYMBOL: font   ! a list of two elements, a font name and size.
+SYMBOL: filled ! is the interior of the shape filled?
+
+: shape>screen ( shape -- x1 y1 x2 y2 )
+    [ shape-x x get + ] keep
+    [ shape-y y get + ] keep
+    [ dup shape-x swap shape-w + x get + ] keep
+    dup shape-y swap shape-h + y get + ;
+
+: rgb-color ( -- rgba ) color get 3unlist rgb ;
+
+GENERIC: draw ( obj -- )
+
+M: rect draw ( rect -- )
+    >r surface get r> shape>screen rgb-color
+    filled get [ boxColor ] [ rectangleColor ] ifte ;
+
+: default-paint ( -- paint )
+    {{
+        [[ x 0 ]]
+        [[ y 0 ]]
+        [[ color [ 0 0 0 ] ]]
+        [[ filled f ]]
+        [[ font [ "Monospaced" 12 ] ]]
+    }} ;

library/ui/shapes.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel math namespaces ;
+
+! Shape protocol.
+
+! These dynamically-bound variables affect the generic word
+! inside?.
+SYMBOL: x ! x translation
+SYMBOL: y ! y translation
+
+! A shape is an object with a defined bounding
+! box, and a notion of interior.
+GENERIC: shape-x
+GENERIC: shape-y
+GENERIC: shape-w
+GENERIC: shape-h
+
+GENERIC: inside? ( point shape -- ? )
+
+: with-translation ( shape quot -- )
+    #! All drawing done inside the quotation is translated
+    #! relative to the shape's origin.
+    [
+        >r dup
+        shape-x x [ + ] change
+        shape-y y [ + ] change
+        r> call
+    ] with-scope ; inline
+
+! A point, represented as a complex number, is the simplest type
+! of shape.
+M: number shape-x real ;
+M: number shape-y imaginary ;
+M: number shape-w drop 0 ;
+M: number shape-h drop 0 ;
+M: number inside? = ;
+
+! A rectangle maps trivially to the shape protocol.
+TUPLE: rect x y w h ;
+M: rect shape-x rect-x ;
+M: rect shape-y rect-y ;
+M: rect shape-w rect-w ;
+M: rect shape-h rect-h ;
+
+: fix-neg ( a b c -- a+c b -c )
+    dup 0 < [ neg tuck >r >r + r> r> ] when ;
+
+C: rect ( x y w h -- rect )
+    #! We handle negative w/h for convinience.
+    >r fix-neg >r fix-neg r> r>
+    [ set-rect-h ] keep
+    [ set-rect-w ] keep
+    [ set-rect-y ] keep
+    [ set-rect-x ] keep ;
+
+: rect-x-extents ( rect -- x1 x2 )
+    dup rect-x x get + swap rect-w dupd + ;
+
+: rect-y-extents ( rect -- x1 x2 )
+    dup rect-y y get + swap rect-h dupd + ;
+
+M: rect inside? ( point rect -- ? )
+    over real over rect-x-extents between? >r
+    swap imaginary swap rect-y-extents between? r> and ;