working on styled text output in UI

library/bootstrap/boot-stage1.factor

@@ -58,6 +58,7 @@ 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"

library/collections/hashtables.factor

@@ -158,3 +158,10 @@ M: hashtable hashcode ( hash -- n )
     ] [
         0 swap hash-bucket hashcode
     ] ifte ;
+
+: cache ( key hash quot -- value | quot: key -- value )
+    pick pick hash [
+        >r 3drop r>
+    ] [
+        pick rot >r >r call dup r> r> set-hash
+    ] ifte* ; inline

library/sdl/sdl-utils.factor

@@ -15,7 +15,7 @@ SYMBOL: surface
 
 : with-screen ( width height bpp flags quot -- )
     #! Set up SDL graphics and call the quotation.
-    SDL_INIT_EVERYTHING SDL_Init drop  TTF_Init
+    SDL_INIT_EVERYTHING SDL_Init drop
     1 SDL_EnableUNICODE drop
     SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
     SDL_EnableKeyRepeat drop

library/styles.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: styles
+USING: kernel namespaces ;
+
+! Colors are lists of three integers, 0..255.
+SYMBOL: foreground ! Used for text and outline shapes.
+SYMBOL: background ! Used for filled shapes.
+SYMBOL: reverse-video
+
+: fg reverse-video get background foreground ? get ;
+: bg reverse-video get foreground background ? get ;
+
+SYMBOL: font
+SYMBOL: font-size
+SYMBOL: font-style
+
+SYMBOL: plain
+SYMBOL: bold
+SYMBOL: italic
+SYMBOL: bold-italic

library/syntax/see.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: prettyprint
 USING: generic hashtables io kernel lists namespaces sequences
-streams strings unparser words ;
+streams strings styles unparser words ;
 
 ! Prettyprinting words
 : vocab-actions ( search -- list )
@@ -40,6 +40,7 @@ streams strings unparser words ;
         [[ "ansi-fg" "0" ]]
         [[ "ansi-bg" "2" ]]
         [[ "fg" [ 255 0 0 ] ]]
+        [[ foreground [ 192 0 0 ] ]]
     ] ;
 
 : comment. ( comment -- ) comment-style write-attr ;

library/test/hashtables.factor

@@ -129,3 +129,10 @@ f 100000000000000000000000000 "testhash" get set-hash
         uncons + +
     ] hash-each
 ] unit-test
+
+<namespace> "cache-test" set
+
+[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
+[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
+[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
+[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test

library/tools/listener.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: listener
-USING: errors kernel lists math memory namespaces parser
+USING: ansi errors io kernel lists math memory namespaces parser
-sequences io strings presentation words unparser vectors ansi ;
+presentation sequences strings styles unparser vectors words ;
 
 SYMBOL: cont-prompt
 SYMBOL: listener-prompt
@@ -14,7 +14,7 @@ global [
 ] bind
 
 : prompt. ( text -- )
-    [ [[ "bold" t ]] ] write-attr
+    [ [[ "bold" t ]] [[ font-style bold ]] ] write-attr
     ! Print the space without a style, to workaround a bug in
     ! the GUI listener where the style from the prompt carries
     ! over to the input

library/ui/buttons.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic kernel lists math namespaces prettyprint sdl
-sequences io sequences ;
+sequences io sequences styles ;
 
 : button-down? ( n -- ? ) hand hand-buttons contains? ;
 

library/ui/checkboxes.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences ;
+USING: generic kernel lists math namespaces sdl sequences
+styles ;
 
 : check-size 8 ;
 

library/ui/editors.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic kernel line-editor lists math namespaces sdl
-sequences strings ;
+sequences strings styles ;
 
 ! An editor gadget wraps a line editor object and passes
 ! gestures to the line editor.
@@ -75,11 +75,11 @@ C: editor ( text -- )
     [ set-editor-text ] keep
     dup editor-actions ;
 
-: offset>x ( offset str -- x )
+: offset>x ( gadget offset str -- x )
-    head font get swap size-string drop ;
+    head >r gadget-font r> size-string drop ;
 
 : caret-pos ( editor -- x y )
-    editor-line [ caret get line-text get ] bind offset>x 0 ;
+    dup editor-line [ caret get line-text get ] bind offset>x 0 ;
 
 : caret-size ( editor -- w h )
     1 swap shape-h ;
@@ -96,4 +96,5 @@ M: editor layout* ( editor -- )
     dup editor-caret swap caret-pos rot move-gadget ;
 
 M: editor draw-shape ( editor -- )
-    [ editor-text ] keep [ draw-string ] with-trans ;
+    [ dup gadget-font swap editor-text ] keep
+    [ draw-string ] with-trans ;

library/ui/ellipses.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl ;
+USING: generic kernel lists math namespaces sdl styles ;
 
 ! An ellipse.
 TUPLE: ellipse x y w h ;

library/ui/fonts.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: alien hashtables io kernel lists namespaces sdl sequences
+styles ;
+
+: ttf-name ( font style -- name )
+    cons [
+        [[ [[ "Monospaced" plain       ]] "VeraMono" ]]
+        [[ [[ "Monospaced" bold        ]] "VeraMoBd" ]]
+        [[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
+        [[ [[ "Monospaced" italic      ]] "VeraMoIt" ]]
+        [[ [[ "Sans Serif" plain       ]] "Vera"     ]]
+        [[ [[ "Sans Serif" bold        ]] "VeraBd"   ]]
+        [[ [[ "Sans Serif" bold-italic ]] "VeraBI"   ]]
+        [[ [[ "Sans Serif" italic      ]] "VeraIt"   ]]
+        [[ [[ "Serif" plain            ]] "VeraSe"   ]]
+        [[ [[ "Serif" bold             ]] "VeraSeBd" ]]
+        [[ [[ "Serif" bold-italic      ]] "VeraBI"   ]]
+        [[ [[ "Serif" italic           ]] "VeraIt"   ]]
+    ] assoc ;
+
+: ttf-path ( name -- string )
+    [ resource-path % "/fonts/" % % ".ttf" % ] make-string ;
+
+: open-font ( [ font style ptsize ] -- alien )
+    3unlist >r ttf-name ttf-path r> TTF_OpenFont ;
+
+SYMBOL: open-fonts
+
+: lookup-font ( font style ptsize -- font )
+    3list open-fonts get [ open-font ] cache ;
+
+global [ open-fonts nest drop ] bind
+
+: ttf-init ( -- )
+    TTF_Init
+    open-fonts [ [ cdr null? not ] hash-subset ] change ;
+
+: gadget-font ( gadget -- font )
+    [ font paint-prop ] keep
+    [ font-style paint-prop ] keep
+    font-size paint-prop
+    lookup-font ;

library/ui/init-world.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel math namespaces ;
+USING: generic kernel math namespaces styles ;
 
 
 global [
@@ -12,7 +12,9 @@ global [
         [[ background [ 255 255 255 ] ]]
         [[ foreground [ 0 0 0 ] ]]
         [[ reverse-video f ]]
-        [[ font [[ "Sans Serif" 12 ]] ]]
+        [[ font "Sans Serif" ]]
+        [[ font-size 12 ]]
+        [[ font-style plain ]]
     }} world get set-gadget-paint
     
     1024 768 world get resize-gadget

library/ui/labels.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic hashtables io kernel lists math namespaces sdl
-sequences ;
+sequences styles ;
 
 ! A label gadget draws a string.
 TUPLE: label text ;
@@ -11,18 +11,14 @@ C: label ( text -- label )
     <empty-gadget> over set-delegate [ set-label-text ] keep ;
 
 : label-size ( gadget text -- w h )
-    >r font paint-prop r> size-string ;
+    >r gadget-font r> size-string ;
 
 M: label pref-size ( label -- w h )
     dup label-text label-size ;
 
 M: label draw-shape ( label -- )
-    [ label-text ] keep [ draw-string ] with-trans ;
+    [ dup gadget-font swap label-text ] keep
+    [ draw-string ] with-trans ;
 
 : <styled-label> ( style text -- label )
-    <label> swap [
+    <label> swap alist>hash over set-gadget-paint ;
-        unswons [
-            [[ "fg" foreground ]]
-            [[ "bg" background ]]
-        ] assoc swons
-    ] map alist>hash over set-gadget-paint ;

library/ui/lines.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl ;
+USING: generic kernel lists math namespaces sdl styles ;
 
 ! A line.
 TUPLE: line x y w h ;

library/ui/load.factor

@@ -9,6 +9,7 @@ USING: kernel parser sequences io ;
     "/library/ui/gadgets.factor"
     "/library/ui/hierarchy.factor"
     "/library/ui/paint.factor"
+    "/library/ui/fonts.factor"
     "/library/ui/text.factor"
     "/library/ui/gestures.factor"
     "/library/ui/hand.factor"

library/ui/panes.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic kernel line-editor listener lists math namespaces
-sequences io strings threads ;
+sequences io strings threads styles ;
 
 ! A pane is an area that can display text.
 
@@ -23,7 +23,7 @@ TUPLE: pane output active current input continuation ;
     2dup set-pane-active add-gadget ;
 
 : pane-paint ( pane -- )
-    [[ "Monospaced" 12 ]] font set-paint-prop ;
+    "Monospaced" font set-paint-prop ;
 
 : pop-continuation ( pane -- quot )
     dup pane-continuation f rot set-pane-continuation ;
@@ -81,9 +81,3 @@ M: pane stream-close ( stream -- ) drop ;
     <pane> dup
     [ [ clear  print-banner listener ] in-thread ] with-stream
     <scroller> ;
-
-: console ( -- )
-    #! Open an UI console window.
-    <console> "Listener" <tile> world get [
-        shape-size rect> 3/4 * >rect rot resize-gadget
-    ] 2keep add-gadget ;

library/ui/rectangles.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl ;
+USING: generic kernel lists math namespaces sdl styles ;
 
 ! A rectangle maps trivially to the shape protocol.
 TUPLE: rectangle x y w h ;

library/ui/scrolling.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic kernel lists math matrices namespaces sequences
-threads vectors ;
+threads vectors styles ;
 
 ! A viewport can be scrolled.
 

library/ui/shapes.factor

@@ -32,17 +32,7 @@ GENERIC: resize-shape ( w h shape -- )
     >r 3unseq drop r> resize-shape ;
 
 ! The painting protocol. Painting is controlled by various
-! dynamically-scoped variables.
+! dynamically-scoped variables. See library/styles.factor.
-
-! Colors are lists of three integers, 0..255.
-SYMBOL: foreground ! Used for text and outline shapes.
-SYMBOL: background ! Used for filled shapes.
-SYMBOL: reverse-video
-
-: fg reverse-video get background foreground ? get ;
-: bg reverse-video get foreground background ? get ;
-
-SYMBOL: font  ! a list of two elements, a font name and size.
 
 GENERIC: draw-shape ( obj -- )
 

library/ui/splitters.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math matrices namespaces sequences ;
+USING: generic kernel lists math matrices namespaces sequences
+styles ;
 
 TUPLE: divider splitter ;
 

library/ui/text.factor

@@ -1,42 +1,8 @@
-! Strings are shapes too. This is somewhat of a hack and strings
+! Copyright (C) 2005 Slava Pestov.
-! do not have x/y co-ordinates.
+! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: alien hashtables kernel lists namespaces sdl sequences
-io strings ;
+strings styles io ;
-
-SYMBOL: fonts
-
-: <font> ( name ptsize -- font )
-    >r resource-path swap append r> TTF_OpenFont ;
-
-SYMBOL: logical-fonts
-
-: logical-font ( name -- name )
-    dup logical-fonts get hash dup [ nip ] [ drop ] ifte ;
-
-global [
-    {{
-        [[ "Monospaced" "/fonts/VeraMono.ttf" ]]
-        [[ "Serif" "/fonts/VeraSe.ttf" ]]
-        [[ "Sans Serif" "/fonts/Vera.ttf" ]]
-    }} logical-fonts set
-] bind
-
-: (lookup-font) ( [[ name ptsize ]] -- font )
-    unswons logical-font swons dup get dup alien? [
-        dup alien-address 0 = [
-            drop f
-        ] when
-    ] when ;
-
-: lookup-font ( [[ name ptsize ]] -- font )
-    fonts get [
-        (lookup-font) [
-            nip
-        ] [
-            [ uncons <font> dup ] keep set
-        ] ifte*
-    ] bind ;
 
 : surface-rect ( x y surface -- rect )
     dup surface-w swap surface-h make-rect ;
@@ -56,23 +22,20 @@ global [
     ] when ;
 
 : size-string ( font text -- w h )
-    >r lookup-font r> filter-nulls dup empty? [
+    filter-nulls dup empty? [
-        drop TTF_FontHeight 0 swap
+        drop 0 swap TTF_FontHeight
     ] [
         0 <int> 0 <int> [ TTF_SizeUNICODE drop ] 2keep
         swap *int swap *int
     ] ifte ;
 
-: draw-string ( text -- )
+: draw-string ( font text -- )
-    dup empty? [
+    filter-nulls dup empty? [
-        drop
+        2drop
     ] [
-        filter-nulls font get lookup-font swap
         fg 3unlist make-color
         bg 3unlist make-color
         TTF_RenderUNICODE_Shaded
         [ >r x get y get r> draw-surface ] keep
         SDL_FreeSurface
     ] ifte ;
-
-global [ <namespace> fonts set ] bind

library/ui/ui.factor

@@ -11,6 +11,7 @@ IN: shells
     world get shape-size 0 SDL_RESIZABLE [
         0 x set 0 y set [
             "Factor " version append dup SDL_WM_SetCaption
+            ttf-init
             start-world
             run-world
         ] with-screen

library/vocabularies.factor

@@ -97,6 +97,6 @@ SYMBOL: vocabularies
         "hashtables" "inference" "interpreter" "jedit" "kernel"
         "listener" "lists" "math" "matrices" "memory"
         "namespaces" "parser" "prettyprint" "processes"
-        "sequences" "io" "strings" "syntax" "test" "threads"
+        "sequences" "io" "strings" "styles" "syntax" "test"
-        "unparser" "vectors" "words" "scratchpad"
+        "threads" "unparser" "vectors" "words" "scratchpad"
     ] "use" set ;