From 5aec661b928e322a3bf88a617b2dd9fb694ca51f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 26 Jan 2009 16:25:57 -0600 Subject: [PATCH] Rename font key in io.styles to font-name for clarity; clean up some nefarious stack shuffling in ui.gadgets.panes --- basis/help/stylesheet/stylesheet.factor | 14 ++-- basis/html/streams/streams.factor | 2 +- basis/io/styles/styles-docs.factor | 6 +- basis/io/styles/styles.factor | 2 +- basis/ui/gadgets/panes/panes.factor | 100 +++++++++++++----------- 5 files changed, 65 insertions(+), 59 deletions(-) diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 50357db8cf..358f054b31 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2006 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.styles namespaces colors ; IN: help.stylesheet SYMBOL: default-span-style H{ - { font "sans-serif" } + { font-name "sans-serif" } { font-size 12 } { font-style plain } } default-span-style set-global @@ -29,7 +29,7 @@ H{ { font-style bold } } strong-style set-global SYMBOL: title-style H{ - { font "sans-serif" } + { font-name "sans-serif" } { font-size 18 } { font-style bold } { wrap-margin 500 } @@ -42,21 +42,21 @@ H{ { font-size 10 } } help-path-style set-global SYMBOL: heading-style H{ - { font "sans-serif" } + { font-name "sans-serif" } { font-size 16 } { font-style bold } } heading-style set-global SYMBOL: subsection-style H{ - { font "sans-serif" } + { font-name "sans-serif" } { font-size 14 } { font-style bold } } subsection-style set-global SYMBOL: snippet-style H{ - { font "monospace" } + { font-name "monospace" } { font-size 12 } { foreground T{ rgba f 0.1 0.1 0.4 1 } } } snippet-style set-global @@ -73,7 +73,7 @@ H{ { font-style bold } } input-style set-global SYMBOL: url-style H{ - { font "monospace" } + { font-name "monospace" } { foreground T{ rgba f 0.0 0.0 1.0 1.0 } } } url-style set-global diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 709b65761e..f799d7a438 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -86,7 +86,7 @@ TUPLE: html-sub-stream < html-stream style parent ; [ foreground [ fg-css, ] apply-style background [ bg-css, ] apply-style - font [ font-css, ] apply-style + font-name [ font-css, ] apply-style font-style [ style-css, ] apply-style font-size [ size-css, ] apply-style ] make-css ; diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index 1ea1e6c6b7..2aa25212e4 100644 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -115,7 +115,7 @@ ARTICLE: "character-styles" "Character styles" "Character styles for " { $link stream-format } " and " { $link with-style } ":" { $subsection foreground } { $subsection background } -{ $subsection font } +{ $subsection font-name } { $subsection font-size } { $subsection font-style } { $subsection presented } ; @@ -195,11 +195,11 @@ HELP: background } } ; -HELP: font +HELP: font-name { $description "Character style. Font family named by a string." } { $examples "This example outputs some different font sizes:" - { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font associate format nl ] each" } + { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font-name associate format nl ] each" } } ; HELP: font-size diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index f24160abfa..6ebb4952e7 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -130,7 +130,7 @@ SYMBOL: bold-italic ! Character styles SYMBOL: foreground SYMBOL: background -SYMBOL: font +SYMBOL: font-name SYMBOL: font-size SYMBOL: font-style diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 566b1f5e62..3295ac5a8a 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel namespaces sequences -io.styles strings quotations math opengl combinators +io.styles strings quotations math opengl combinators memoize math.vectors sorting splitting assocs classes.tuple models continuations destructors accessors math.geometry.rect fry ui.gadgets ui.gadgets.borders ui.gadgets.buttons @@ -19,15 +19,15 @@ selection-color caret mark selecting? ; : clear-selection ( pane -- pane ) f >>caret f >>mark ; -: add-output ( pane current -- pane ) - [ >>output ] [ add-gadget ] bi ; +: add-output ( pane current -- pane ) + [ >>output ] [ add-gadget ] bi ; : add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ; -: prepare-line ( pane -- pane ) +: prepare-line ( pane -- ) clear-selection - dup prototype>> clone add-current ; + dup prototype>> clone add-current drop ; : pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ; @@ -51,7 +51,7 @@ M: pane gadget-selection ( pane -- string/f ) { 0 1 } >>orientation >>prototype add-output - prepare-line + dup prepare-line selection-color >>selection-color ; : ( -- pane ) pane new-pane ; @@ -77,12 +77,12 @@ M: node draw-selection ( loc node -- ) M: pane draw-gadget* dup gadget-selection? [ - dup selection-color>> gl-color - origin get over rect-loc v- swap selected-children - [ draw-selection ] with each - ] [ - drop - ] if ; + [ selection-color>> gl-color ] + [ + [ [ origin get ] dip loc>> v- ] keep selected-children + [ draw-selection ] with each + ] bi + ] [ drop ] if ; : scroll-pane ( pane -- ) dup scrolls?>> [ scroll>bottom ] [ drop ] if ; @@ -100,20 +100,22 @@ C: pane-stream : smash-pane ( pane -- gadget ) output>> smash-line ; -: pane-nl ( pane -- pane ) - dup current>> dup unparent smash-line - over output>> add-incremental - prepare-line ; +: pane-nl ( pane -- ) + [ + [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi + add-incremental + ] + [ prepare-line ] bi ; -: pane-write ( pane seq -- ) - [ pane-nl ] - [ over current>> stream-write ] - interleave drop ; +: pane-write ( seq pane -- ) + [ '[ _ pane-nl ] ] + [ '[ _ current>> stream-write ] ] bi + interleave ; -: pane-format ( style pane seq -- ) - [ pane-nl ] - [ 2over current>> stream-format ] - interleave 2drop ; +: pane-format ( seq style pane -- ) + [ '[ _ drop _ pane-nl ] ] + [ '[ _ _ current>> stream-format ] ] 2bi + interleave ; GENERIC: write-gadget ( gadget stream -- ) @@ -157,16 +159,16 @@ M: pane-control model-changed ( model pane-control -- ) [ pane>> ] dip keep scroll-pane ; inline M: pane-stream stream-nl - [ pane-nl drop ] do-pane-stream ; + [ pane-nl ] do-pane-stream ; M: pane-stream stream-write1 [ current>> stream-write1 ] do-pane-stream ; M: pane-stream stream-write - [ swap string-lines pane-write ] do-pane-stream ; + [ [ string-lines ] dip pane-write ] do-pane-stream ; M: pane-stream stream-format - [ rot string-lines pane-format ] do-pane-stream ; + [ [ string-lines ] 2dip pane-format ] do-pane-stream ; M: pane-stream dispose drop ; @@ -186,24 +188,28 @@ M: pane-stream make-span-stream : apply-background-style ( style gadget -- style gadget ) background [ solid-interior ] apply-style ; -: specified-font ( style -- font ) - - swap - [ font swap at "monospace" or >>name ] - [ - font-style swap at { - { f [ ] } - { plain [ ] } - { bold [ t >>bold? ] } - { italic [ t >>italic? ] } - { bold-italic [ t >>bold? t >>italic? ] } - } case - ] - [ font-size swap at 12 or >>size ] - tri ; +MEMO: specified-font ( font style size -- font ) + #! We memoize here to avoid creating lots of duplicate font objects. + [ ] 3dip + [ "monospace" or >>name ] + [ + { + { f [ ] } + { plain [ ] } + { bold [ t >>bold? ] } + { italic [ t >>italic? ] } + { bold-italic [ t >>bold? t >>italic? ] } + } case + ] + [ 12 or >>size ] + tri* ; : apply-font-style ( style gadget -- style gadget ) - over specified-font >>font ; + over + [ font-name swap at ] + [ font-style swap at ] + [ font-size swap at ] + tri specified-font >>font ; : apply-presentation-style ( style gadget -- style gadget ) presented [ ] apply-style ; @@ -331,10 +337,10 @@ M: paragraph stream-format presented pick at [ gadget-format ] [ - rot " " split - [ 2dup gadget-bl ] - [ 2over gadget-format ] interleave - 2drop + [ " " split ] 2dip + [ '[ _ _ gadget-bl ] ] + [ '[ _ _ gadget-format ] ] 2bi + interleave ] if ; : caret>mark ( pane -- pane )