minor UI fixes, updating html streams to not use obsolete style keys

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 75960eb0863c56919a39f4a8fb458cbd46ea35cb..0854903ed8b827cf29c0260de414cc2e950c5fe4 100644 (file)
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -48,6 +48,7 @@ parser prettyprint sequences io vectors words ;
         "/library/vocabularies.factor"
         "/library/errors.factor"
         "/library/continuations.factor"
+        "/library/styles.factor"
 
         "/library/io/stream.factor"
         "/library/io/duplex-stream.factor"
@@ -58,7 +59,6 @@ parser prettyprint sequences io vectors words ;
         "/library/io/files.factor"
 
         "/library/threads.factor"
-        "/library/styles.factor"
 
         "/library/syntax/parse-numbers.factor"
         "/library/syntax/parse-words.factor"

diff --git a/library/httpd/html.factor b/library/httpd/html.factor
index bf270ec3ff65b352c19dec8412efa6ea48118cd2..3e1a4b89249730f29d6a91485404604402172b26 100644 (file)
--- a/library/httpd/html.factor
+++ b/library/httpd/html.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: html
-USING: generic kernel lists namespaces presentation sequences
-io strings unparser http ;
+USING: generic http io kernel lists namespaces presentation
+sequences strings styles unparser words ;
 
 : html-entities ( -- alist )
     [
@@ -22,36 +22,35 @@ io strings unparser http ;
         [ dup html-entities assoc [ % ] [ , ] ?ifte ] each
     ] make-string ;
 
-: >hex-color ( triplet -- hex )
-    [ CHAR: # , [ >hex 2 CHAR: 0 pad-left % ] each ] make-string ;
+: hex-color, ( triplet -- )
+    [ >hex 2 CHAR: 0 pad-left % ] each ;
 
 : fg-css, ( color -- )
-    "color: " , >hex-color , "; " , ;
+    "color: #" % hex-color, "; " % ;
 
-: bold-css, ( flag -- )
-    [ "font-weight: bold; " , ] when ;
-
-: italics-css, ( flag -- )
-    [ "font-style: italic; " , ] when ;
+: style-css, ( flag -- )
+    dup [ italic bold-italic ] contains?
+    [ "font-style: italic; " % ] when
+    [ bold bold-italic ] contains?
+    [ "font-weight: bold; " % ] when ;
 
 : underline-css, ( flag -- )
-    [ "text-decoration: underline; " , ] when ;
+    [ "text-decoration: underline; " % ] when ;
 
 : size-css, ( size -- )
-    "font-size: " , unparse , "; " , ;
+    "font-size: " % unparse % "; " % ;
 
 : font-css, ( font -- )
-    "font-family: " , , "; " , ;
+    "font-family: " % % "; " % ;
 
 : css-style ( style -- )
     [
         [
-            [ "fg"        fg-css, ]
-            [ "bold"      bold-css, ]
-            [ "italics"   italics-css, ]
-            [ "underline" underline-css, ]
-            [ "size"      size-css, ]
-            [ "font"      font-css, ]
+            [ foreground  fg-css, ]
+            [ font        font-css, ]
+            [ font-style  style-css, ]
+            [ font-size   size-css, ]
+            [ underline   underline-css, ]
         ] assoc-apply
     ] make-string ;
 
@@ -70,7 +69,7 @@ io strings unparser http ;
     ] when* "/" ?tail drop ;
 
 : file-link-href ( path -- href )
-    [ "/" , resolve-file-link url-encode , ] make-string ;
+    [ "/" % resolve-file-link url-encode % ] make-string ;
 
 : file-link-tag ( style quot -- )
     over "file" swap assoc [
@@ -79,20 +78,19 @@ io strings unparser http ;
         call
     ] ifte* ;
 
-: browser-link-href ( style -- href )
-    dup "word" swap assoc url-encode
-    swap "vocab" swap assoc url-encode
-    [ "/responder/browser/?vocab=" , , "&word=" , , ] make-string ;
+: browser-link-href ( word -- href )
+    dup word-name swap word-vocabulary
+    [ "/responder/browser/?vocab=" % % "&word=" % % ] make-string ;
 
 : browser-link-tag ( style quot -- style )
-    over "word" swap assoc [
-        <a href= over browser-link-href a> call </a>
+    over presented swap assoc dup word? [
+        <a href= browser-link-href a> call </a>
     ] [
-        call
+        drop call
     ] ifte ;
 
 : icon-tag ( string style quot -- )
-    over "icon" swap assoc dup [
+    over icon swap assoc dup [
         <img src= "/responder/resource/" swap append img/>
         #! Ignore the quotation, since no further style
         #! can be applied
@@ -120,12 +118,12 @@ C: html-stream ( stream -- stream )
     #! written, and supports writing attributed strings with
     #! the following attributes:
     #!
-    #! fg - an rgb triplet in a list
-    #! bg - an rgb triplet in a list
-    #! bold
-    #! italics
+    #! foreground - an rgb triplet in a list
+    #! background - an rgb triplet in a list
+    #! font
+    #! font-style
+    #! font-size
     #! underline
-    #! size
     #! icon
     #! file
     #! word

diff --git a/library/io/directories.factor b/library/io/directories.factor
index f80fc03042b9871e0770f94ab73d9ccdc8c92a28..399e6d1f9505a0d3e7836e87ea089732f6497bf2 100644 (file)
--- a/library/io/directories.factor
+++ b/library/io/directories.factor
@@ -6,33 +6,19 @@ sequences strings unparser ;
 
 ! Hyperlinked directory listings.
 
-: file-actions ( -- list )
-    [
-        [[ "Push"             ""           ]]
-        [[ "Run file"         "run-file"   ]]
-        [[ "List directory"   "directory." ]]
-        [[ "Change directory" "cd"         ]]
-    ] ;
-
 : dir-icon "/library/icons/Folder.png" ;
- : file-icon "/library/icons/File.png" ;
- : file-icon. directory? dir-icon file-icon ? write-icon ;
+: file-icon "/library/icons/File.png" ;
+: file-icon. directory? dir-icon file-icon ? write-icon ;
 
 : file-link. ( dir name -- )
-    tuck "/" swap append3 dup "file" swons swap
-    unparse file-actions <actions> "actions" swons
-    2list write-attr ;
+    tuck path+ "file" swons unit write-attr ;
 
 : file. ( dir name -- )
     #! If "doc-root" set, create links relative to it.
-    2dup "/" swap append3 file-icon. bl file-link. terpri ;
+    2dup path+ file-icon. bl file-link. terpri ;
 
 : directory. ( dir -- )
     #! If "doc-root" set, create links relative to it.
     dup directory [
-        dup [ "." ".." ] contains? [
-            2drop
-        ] [
-            file.
-        ] ifte
+        dup [ "." ".." ] contains? [ 2drop ] [ file. ] ifte
     ] each-with ;

diff --git a/library/io/stdio.factor b/library/io/stdio.factor
index 2562c8f0a6324f0138bec7c1e56b813c65fa9c4c..414948603fe07c8cf8859206d1a650a260be685f 100644 (file)
--- a/library/io/stdio.factor
+++ b/library/io/stdio.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: io
-USING: errors kernel lists namespaces generic strings ;
+USING: errors generic kernel lists namespaces strings styles ;
 
 : flush      ( -- )              stdio get stream-flush ;
 : read-line  ( -- string )       stdio get stream-readln ;
@@ -17,7 +17,7 @@ USING: errors kernel lists namespaces generic strings ;
 
 : write-icon ( resource -- )
     #! Write an icon. Eg, /library/icons/File.png
-    "icon" swons unit "" swap write-attr ;
+    icon swons unit "" swap write-attr ;
 
 : with-stream ( stream quot -- )
     #! Close the stream no matter what happends.

diff --git a/library/styles.factor b/library/styles.factor
index d24f0b561dc1c9f5361b95e8468b6b3a7ae74c2c..5c4abd7978eaa2dec3a778c2042b1dd6a2d29a05 100644 (file)
--- a/library/styles.factor
+++ b/library/styles.factor
@@ -29,4 +29,8 @@ SYMBOL: bold
 SYMBOL: italic
 SYMBOL: bold-italic
 
+SYMBOL: underline
+
 SYMBOL: presented
+
+SYMBOL: icon

diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index 715c3d835e8b402e8775f9d75a351297743f6e53..cb7220b4e4020a12d2178d2a905089802d0ba90a 100644 (file)
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -13,7 +13,7 @@ SYMBOL: recursion-check
 GENERIC: prettyprint* ( indent obj -- indent )
 
 M: object prettyprint* ( indent obj -- indent )
-    unparse write ;
+    dup unparse swap presented swons unit write-attr ;
 
 : word-attrs ( word -- style )
     #! Return the style values for the HTML word browser

diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor
index ae0a3e72f128410ae3061e5e1910b26fc08bfc2e..bed547663072cace5fdadda86716b76230e1975a 100644 (file)
--- a/library/ui/buttons.factor
+++ b/library/ui/buttons.factor
@@ -21,7 +21,7 @@ sequences io sequences styles ;
 : button-update ( button -- )
     dup dup mouse-over? rollover set-paint-prop
     dup dup button-pressed? reverse-video set-paint-prop
-    redraw ;
+    relayout ;
 
 : button-clicked ( button -- )
     #! If the mouse is released while still inside the button,

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index 79098c6601e19d21d53a2e9dd8469ad4c939e865..5412b2a8e1d1a461d460d6d7bc0a854df1352eb4 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -7,10 +7,7 @@ sequences vectors ;
 ! A gadget is a shape, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent. A gadget
 ! delegates to its shape.
-TUPLE: gadget
-    paint gestures
-    relayout? redraw? root?
-    parent children ;
+TUPLE: gadget paint gestures relayout? root? parent children ;
 
 : gadget-child gadget-children car ;
 
@@ -23,7 +20,6 @@ C: gadget ( shape -- gadget )
 
 : <plain-gadget> ( -- gadget ) 0 0 0 0 <plain-rect> <gadget> ;
 
-DEFER: relayout
 DEFER: add-invalid
 
 : invalidate ( gadget -- )
@@ -32,20 +28,21 @@ DEFER: add-invalid
 : relayout ( gadget -- )
     #! Relayout and redraw a gadget and its parent before the
     #! next iteration of the event loop.
-    dup redraw
     dup gadget-relayout? [
         drop
     ] [
         dup invalidate
         dup gadget-root?
-        [ world get add-invalid ]
+        [ add-invalid ]
         [ gadget-parent [ relayout ] when* ] ifte
     ] ifte ;
 
+: (relayout-down)
+    dup invalidate gadget-children [ (relayout-down) ] each ;
+
 : relayout-down ( gadget -- )
     #! Relayout a gadget and its children.
-    dup world get add-invalid
-    dup invalidate gadget-children [ relayout-down ] each ;
+    dup add-invalid (relayout-down) ;
 
 : move-gadget ( x y gadget -- )
     >r 0 3vector r> set-shape-loc ;

diff --git a/library/ui/hand.factor b/library/ui/hand.factor
index 073fcc1bc05975b2b94b22826549b85ed937d7ad..6db6283057aafe0102b222332537397f7934606b 100644 (file)
--- a/library/ui/hand.factor
+++ b/library/ui/hand.factor
@@ -49,8 +49,6 @@ TUPLE: hand world
     click-loc click-rel clicked buttons
     gadget focus ;
 
-: hand-click-pos hand-click-loc 3unseq drop rect> ;
-
 C: hand ( world -- hand )
     <empty-gadget>
     over set-delegate

diff --git a/library/ui/init-world.factor b/library/ui/init-world.factor
index 275d4a273d0dc7a00bb5c7df530a29a63c0ea71f..abc2c2ef756c40fcbd988648d1f173b15dc3c776 100644 (file)
--- a/library/ui/init-world.factor
+++ b/library/ui/init-world.factor
@@ -3,29 +3,36 @@
 IN: gadgets
 USING: generic io kernel listener math namespaces styles threads ;
 
-
-global [
-    <world> world set
-    
-    {{
-        [[ background [ 255 255 255 ] ]]
-        [[ rollover-bg [ 255 255 204 ] ]]
-        [[ foreground [ 0 0 0 ] ]]
-        [[ reverse-video f ]]
-        [[ font "Sans Serif" ]]
-        [[ font-size 12 ]]
-        [[ font-style plain ]]
-    }} world get set-gadget-paint
+: init-world
+    global [
+        <world> world set
+        
+        {{
+            [[ background [ 255 255 255 ] ]]
+            [[ rollover-bg [ 255 255 204 ] ]]
+            [[ foreground [ 0 0 0 ] ]]
+            [[ reverse-video f ]]
+            [[ font "Sans Serif" ]]
+            [[ font-size 12 ]]
+            [[ font-style plain ]]
+        }} world get set-gadget-paint
+        
+        { 1024 768 0 } world get set-gadget-dim
+        
+        <plain-gadget> add-layer
     
-    { 1024 768 0 } world get set-gadget-dim
-    
-    <plain-gadget> add-layer
+        <pane> dup
+        
+        <scroller> "Stack display goes here" <label> 3/4 <y-splitter> add-layer
+        
+        dup [ [ clear  print-banner listener ] in-thread ] with-stream
+        
+        request-focus
+    ] bind ;
 
-    <pane> dup
-    
-    <scroller> "Stack display goes here" <label> 3/4 <y-splitter> add-layer
-    
-    dup [ [ clear  print-banner listener ] in-thread ] with-stream
-    
-    request-focus
-] bind
+SYMBOL: first-time
+
+global [ first-time on ] bind
+
+: ?init-world
+    first-time get [ init-world first-time off ] when ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index 2608b977edc1d117638fe47c4ce9a2b85fdf0f7f..62896615dc6aec18a11b3b1ed45d07aed7ec2ff6 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -4,11 +4,6 @@ IN: gadgets
 USING: generic hashtables kernel lists math namespaces sdl
 io strings sequences ;
 
-: redraw ( gadget -- )
-    #! Redraw a gadget before the next iteration of the event
-    #! loop.
-    drop  t world get set-gadget-redraw? ;
-
 ! Clipping
 
 SYMBOL: clip
@@ -68,7 +63,6 @@ SYMBOL: clip
     #! All drawing done inside draw-shape is done with the
     #! gadget's paint. If the gadget does not have any custom
     #! paint, just call the quotation.
-    f over set-gadget-redraw?
     dup gadget-paint [
         dup [
             [

diff --git a/library/ui/ui.factor b/library/ui/ui.factor
index 6ef894d8a5b52fd3adf21478cc81790018953fea..7f6ffe1f5033c23b06c582debf0f78f81ac9f060 100644 (file)
--- a/library/ui/ui.factor
+++ b/library/ui/ui.factor
@@ -8,6 +8,7 @@ IN: shells
 : ui ( -- )
     #! Start the Factor graphics subsystem with the given screen
     #! dimensions.
+    ?init-world
     world get shape-size 0 SDL_RESIZABLE [
         0 x set 0 y set [
             "Factor " version append dup SDL_WM_SetCaption

diff --git a/library/ui/world.factor b/library/ui/world.factor
index d75445436ca15030cad7a45c3d837df46b77c68e..1ba9d14cd91ad4d231947dcb314b7dd69cee33a7 100644 (file)
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -17,18 +17,15 @@ C: world ( -- world )
     t over set-gadget-root?
     dup <hand> over set-world-hand ;
 
-: add-invalid ( gadget world -- )
-    [ world-invalid cons ] keep set-world-invalid ;
+: add-invalid ( gadget -- )
+    world get [ world-invalid cons ] keep set-world-invalid ;
 
-: pop-invalid ( world -- list )
-    [ world-invalid f ] keep set-world-invalid ;
+: pop-invalid ( -- list )
+    world get [ world-invalid f ] keep set-world-invalid ;
 
-: layout-world ( world -- )
-    dup world-invalid [
-        dup pop-invalid [ layout ] each layout-world
-    ] [
-        drop
-    ] ifte ;
+: layout-world ( -- )
+    world get world-invalid
+    [ pop-invalid [ layout ] each layout-world ] when ;
 
 : add-layer ( gadget -- )
     world get add-gadget ;
@@ -47,23 +44,16 @@ M: world inside? ( point world -- ? ) 2drop t ;
 : hand world get world-hand ;
 
 : draw-world ( world -- )
-    dup gadget-redraw? [
-        [
-            dup 0 0 width get height get <rectangle> clip set-paint-prop
-            draw-gadget
-        ] with-surface
-    ] [
-        drop
-    ] ifte ;
+    [
+        dup 0 0 width get height get <rectangle> clip set-paint-prop
+        draw-gadget
+    ] with-surface ;
 
 DEFER: handle-event
 
-: world-step ( world -- ? )
-    world get dup world-running? [
-        dup layout-world draw-world  t
-    ] [
-        drop f
-    ] ifte ;
+: world-step ( -- ? )
+    world get dup world-invalid >r layout-world r>
+    [ draw-world ] [ drop ] ifte ;
 
 : next-event ( -- event ? )
     <event> dup SDL_PollEvent ;
@@ -74,7 +64,8 @@ DEFER: handle-event
     next-event [
         handle-event run-world
     ] [
-        drop world-step [ yield run-world ] when
+        drop world-step
+        world get world-running? [ yield run-world ] when
     ] ifte ;
 
 : ensure-ui ( -- )