dlists.factor, working on UI

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index ce87bc6a82694735db29df7a6da2328a89e64983..1cd6fb96c02a50a0aa48cbb35c2bbeb8bd5c473e 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -78,6 +78,7 @@
 - worddef props\r
 - prettyprint: detect circular structure\r
 - vectors: ensure its ok with bignum indices\r
+- parsing words don't print readably\r
 \r
 + httpd:\r
 \r

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 1ecaf4912c92fb2596d99b1329caa4c9f6e3ff46..c7341c7feec9f95fb00f8a77bd1f71ccd4df8193 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -27,6 +27,7 @@ USING: kernel lists parser stdio words namespaces ;
     "/library/math/float.factor"\r
     "/library/math/complex.factor"\r
     "/library/lists.factor"\r
+    "/library/dlists.factor"\r
     "/library/vectors.factor"\r
     "/library/strings.factor"\r
     "/library/hashtables.factor"\r

diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor
index 43d49a61b93f1f80fafaaddc3059ef7c8e8a732a..dc22e2a20ae0a61150761c21fb1701acdcebfd80 100644 (file)
--- a/library/bootstrap/boot.factor
+++ b/library/bootstrap/boot.factor
@@ -20,6 +20,7 @@ words hashtables ;
     "/library/math/float.factor" parse-resource append,
     "/library/math/complex.factor" parse-resource append,
     "/library/lists.factor" parse-resource append,
+    "/library/dlists.factor" parse-resource append,
     "/library/vectors.factor" parse-resource append,
     "/library/strings.factor" parse-resource append,
     "/library/hashtables.factor" parse-resource append,

diff --git a/library/dlists.factor b/library/dlists.factor
new file mode 100644 (file)
index 0000000..dcc47c7
--- /dev/null
+++ b/library/dlists.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2005 Mackenzie Straight.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: lists USING: generic kernel math ;
+
+! Double-linked lists.
+
+TUPLE: dlist first last ;
+TUPLE: dlist-node next prev data ;
+
+C: dlist ;
+C: dlist-node
+    [ set-dlist-node-next ] keep
+    [ set-dlist-node-prev ] keep
+    [ set-dlist-node-data ] keep ;
+
+: dlist-push-end ( data dlist -- )
+    [ dlist-last f <dlist-node> ] keep
+    [ dlist-last [ dupd set-dlist-node-next ] when* ] keep
+    2dup set-dlist-last
+    dup dlist-first [ 2drop ] [ set-dlist-first ] ifte ;
+
+: dlist-empty? ( dlist -- ? )
+    dlist-first f = ;
+
+: (dlist-pop-front) ( dlist -- data )
+    [ dlist-first dlist-node-data ] keep
+    [ dup dlist-first dlist-node-next swap set-dlist-first ] keep
+    dup dlist-first [ drop ] [ f swap set-dlist-last ] ifte ;
+
+: dlist-pop-front ( dlist -- data )
+    dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] ifte ;

diff --git a/library/lists.factor b/library/lists.factor
index 00591dcd2204e36aa012654d2ec82f7f95a42ecf..f1cea1f2552d927ff271121df595fab000f047e4 100644 (file)
--- a/library/lists.factor
+++ b/library/lists.factor
@@ -166,30 +166,3 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
     #! Make a list of elements that occur in list2 but not
     #! list1.
     [ over contains? not ] subset nip ;
-
-TUPLE: dlist first last ;
-TUPLE: dlist-node next prev data ;
-
-C: dlist ;
-C: dlist-node
-    [ set-dlist-node-next ] keep
-    [ set-dlist-node-prev ] keep
-    [ set-dlist-node-data ] keep ;
-
-: dlist-push-end ( data dlist -- )
-    [ dlist-last f <dlist-node> ] keep
-    [ dlist-last [ dupd set-dlist-node-next ] when* ] keep
-    2dup set-dlist-last
-    dup dlist-first [ 2drop ] [ set-dlist-first ] ifte ;
-
-: dlist-empty? ( dlist -- ? )
-    dlist-first f = ;
-
-: (dlist-pop-front) ( dlist -- data )
-    [ dlist-first dlist-node-data ] keep
-    [ dup dlist-first dlist-node-next swap set-dlist-first ] keep
-    dup dlist-first [ drop ] [ f swap set-dlist-last ] ifte ;
-
-: dlist-pop-front ( dlist -- data )
-    dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] ifte ;
-

diff --git a/library/threads.factor b/library/threads.factor
index 30f719c8d6ab49269b9e894064d4986bf3e91bcc..8cda298a8d5a7bdea66951594ff050abc56042e9 100644 (file)
--- a/library/threads.factor
+++ b/library/threads.factor
@@ -1,4 +1,5 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: threads
 USING: io-internals kernel kernel-internals lists namespaces ;
@@ -38,4 +39,3 @@ USING: io-internals kernel kernel-internals lists namespaces ;
     #! eventually be restored by a future call to (yield) or
     #! yield.
     [ schedule-thread (yield) ] callcc0 ;
-

diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor
index bfb6a793df7d0255415f3caf240f4651c56c93b0..d4f1b73027240bb21b52ccb3224b0c8535dc888a 100644 (file)
--- a/library/ui/buttons.factor
+++ b/library/ui/buttons.factor
@@ -51,8 +51,12 @@ USING: generic kernel lists math namespaces sdl ;
 : <button> ( label quot -- button )
     >r <label> bevel-border dup r> button-actions ;
 
+: <cross> ( w h -- cross )
+    2dup >r >r 0 0 r> r> <line> <gadget>
+    >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r> 2list <stack> ;
+
 : <check-box> ( label quot -- checkbox )
     >r 0 0 0 0 <rectangle> <shelf>
     [ >r <label> r> add-gadget ] keep
-    [ >r f bevel-border r> add-gadget ] keep dup
+    [ >r 11 11 <cross> bevel-border r> add-gadget ] keep dup
     r> button-actions ;

diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor
index a6b18d209e1e91b1968dc90c2890e67d0a311408..586b5904f6f19f02063b2a8760d6f7662d06bc4e 100644 (file)
--- a/library/ui/layouts.factor
+++ b/library/ui/layouts.factor
@@ -83,3 +83,17 @@ C: border ( delegate size -- border )
 
 M: border layout* ( border -- )
     dup size-border dup layout-border-x/y layout-border-w/h ;
+
+! A stack just lays out all its children on top of each other.
+TUPLE: stack delegate ;
+C: stack ( list -- stack )
+    0 0 0 0 <rectangle> <gadget>
+    over set-stack-delegate
+    swap [ over add-gadget ] each ;
+
+M: stack layout* ( stack -- )
+    dup gadget-children dup max-width swap max-height
+    rot 3dup resize-gadget
+    gadget-children [
+        >r 2dup r> resize-gadget
+    ] each 2drop ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index 77ddf0cd47fc3a8417dcd048f8a07d2f55f414ee..cf0153e0ad0948bc08ef25649b573214b1445b00 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -36,7 +36,7 @@ C: hollow-rect ( x y w h -- rect )
     [ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
 
 M: hollow-rect draw-shape ( rect -- )
-    >r surface get r> shape>screen foreground get rgb
+    >r surface get r> rect>screen foreground get rgb
     rectangleColor ;
 
 TUPLE: plain-rect delegate ;
@@ -45,7 +45,7 @@ C: plain-rect ( x y w h -- rect )
     [ >r <rectangle> r> set-plain-rect-delegate ] keep ;
 
 M: plain-rect draw-shape ( rect -- )
-    >r surface get r> shape>screen background get rgb
+    >r surface get r> rect>screen background get rgb
      boxColor ;
 
 : x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 )
@@ -87,11 +87,11 @@ C: bevel-rect ( bevel x y w h -- rect )
     ] repeat 2drop ;
 
 M: bevel-rect draw-shape ( rect -- )
-    shape>screen >r >r rect> r> r> rect> 3 draw-bevel ;
+    rect>screen >r >r rect> r> r> rect> 3 draw-bevel ;
 
 M: line draw-shape ( line -- )
     >r surface get r>
-    shape>screen
+    line>screen
     foreground get rgb
     lineColor ;
 

diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor
index 6fef31edfd0e04befaabc4ba0e6107a93424bf4d..a90bfdccbd24025bc6786bd10c3970c1c9ad472b 100644 (file)
--- a/library/ui/shapes.factor
+++ b/library/ui/shapes.factor
@@ -23,12 +23,6 @@ GENERIC: shape-h
 GENERIC: move-shape ( x y shape -- )
 GENERIC: resize-shape ( w h shape -- )
 
-: shape>screen ( shape -- x1 y1 x2 y2 )
-    [ shape-x x get + ] keep
-    [ shape-y y get + ] keep
-    [ shape-w pick + ] keep
-    shape-h pick + ;
-
 : with-translation ( shape quot -- )
     #! All drawing done inside the quotation is translated
     #! relative to the shape's origin.
@@ -80,6 +74,12 @@ M: rectangle shape-y rectangle-y ;
 M: rectangle shape-w rectangle-w ;
 M: rectangle shape-h rectangle-h ;
 
+: rect>screen ( shape -- x1 y1 x2 y2 )
+    [ rectangle-x x get + ] keep
+    [ rectangle-y y get + ] keep
+    [ rectangle-w pick + ] keep
+    rectangle-h pick + ;
+
 : fix-neg ( a b c -- a+c b -c )
     dup 0 < [ neg tuck >r >r + r> r> ] when ;
 
@@ -156,8 +156,14 @@ M: line move-shape ( x y line -- )
 M: line resize-shape ( w h line -- )
     tuck resize-line-h resize-line-w ;
 
+: line>screen ( shape -- x1 y1 x2 y2 )
+    [ line-x x get + ] keep
+    [ line-y y get + ] keep
+    [ dup line-w swap line-x + pick + ] keep
+    dup line-h swap line-y + pick + ; 
+
 : line-inside? ( p d -- ? )
-    tuck proj - absq 2 < ;
+    dupd proj - absq 2 < ;
 
 M: line inside? ( point line -- ? )
     2dup inside-rect? [