bold?
italic?
{ foreground initial: COLOR: black }
-{ background initial: COLOR: white } ;
+{ background initial: COLOR: white }
+shadow ;
: <font> ( -- font )
font new ; inline
[ [ italic?>> ] either? >>italic? ]
[ [ foreground>> ] either? >>foreground ]
[ [ background>> ] either? >>background ]
+ [ [ shadow>> ] either? >>shadow ]
} 2cleave
] when* ;
12 >>size ;
: strip-font-colors ( font -- font' )
- clone f >>background f >>foreground ;
+ clone f >>background f >>foreground f >>shadow ;
TUPLE: metrics width ascent descent height leading cap-height x-height ;
: ($code) ( presentation quot -- )
[
- snippet-style get [
+ code-char-style get [
last-element off
[ ($code-style) ] dip with-nesting
] with-style
: ($see) ( word quot -- )
[
- snippet-style get [
+ code-char-style get [
code-style get swap with-nesting
] with-style
] ($block) ; inline
SYMBOL: link-style
H{
- { foreground COLOR: dark-blue }
+ { foreground COLOR: DodgerBlue4 }
{ font-style bold }
} link-style set-global
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
- { page-color COLOR: light-gray }
+ { foreground T{ rgba f 0.216 0.243 0.282 1.0 } }
+ { shadow COLOR: white }
+ { page-color T{ rgba f 0.94 0.94 0.91 1.0 } }
{ border-width 5 }
} title-style set-global
SYMBOL: help-path-style
-H{ { font-size 10 } } help-path-style set-global
+H{ { font-size 10 } { shadow f } } help-path-style set-global
SYMBOL: heading-style
H{
H{
{ font-name "monospace" }
{ font-size 12 }
- { foreground COLOR: navy-blue }
+ { foreground COLOR: DarkOrange4 }
} snippet-style set-global
+SYMBOL: code-char-style
+H{
+ { font-name "monospace" }
+ { font-size 12 }
+} code-char-style set-global
+
SYMBOL: code-style
H{
- { page-color COLOR: gray80 }
+ { page-color T{ rgba f 0.94 0.94 0.91 1.0 } }
{ border-width 5 }
{ wrap-margin f }
} code-style set-global
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
- { table-border COLOR: light-gray }
+ { table-border T{ rgba f 0.94 0.94 0.91 1.0 } }
} table-style set-global
SYMBOL: list-style
"Character styles for " { $link stream-format } " and " { $link with-style } ":"
{ $subsection foreground }
{ $subsection background }
+{ $subsection shadow }
{ $subsection font-name }
{ $subsection font-size }
{ $subsection font-style }
}
} ;
+HELP: shadow
+{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
+{ $examples
+ { $code
+ "\"Hello world\\n\""
+ "H{ { background COLOR: gray }"
+ " { shadow COLOR: white }"
+ " { font-size 72 }"
+ "} format"
+ }
+} ;
+
HELP: font-name
{ $description "Character style. Font family named by a string." }
{ $examples
! Character styles
SYMBOL: foreground
SYMBOL: background
+SYMBOL: shadow
SYMBOL: font-name
SYMBOL: font-size
SYMBOL: font-style
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors continuations
-generic hashtables assocs kernel math namespaces make sequences
-strings sbufs vectors words prettyprint.config prettyprint.custom
-prettyprint.sections quotations io io.pathnames io.styles math.parser
-effects classes.tuple math.order classes.tuple.private classes
-combinators colors ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+classes.tuple classes.tuple.private colors colors.constants
+combinators continuations effects generic hashtables io
+io.pathnames io.styles kernel make math math.order math.parser
+namespaces prettyprint.config prettyprint.custom
+prettyprint.sections prettyprint.stylesheet quotations sbufs
+sequences strings vectors words words.symbol ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
?effect-height 0 < [ end-group ] when ;
! Atoms
-: word-style ( word -- style )
- dup "word-style" word-prop >hashtable [
- [
- [ presented set ]
- [
- [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
- [ bold font-style set ] when
- ] bi
- ] bind
- ] keep ;
-
: word-name* ( word -- str )
name>> "( no name )" or ;
M: f pprint* drop \ f pprint-word ;
+: pprint-effect ( effect -- )
+ [ effect>string ] [ effect-style ] bi styled-text ;
+
! Strings
: ch>ascii-escape ( ch -- str )
H{
] when
] when ;
-: string-style ( obj -- hash )
- [
- presented set
- T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
- ] H{ } make-assoc ;
-
: unparse-string ( str prefix suffix -- str )
[ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
--- /dev/null
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors.constants hashtables io.styles kernel namespaces
+words words.symbol ;
+IN: prettyprint.stylesheet
+
+: word-style ( word -- style )
+ dup "word-style" word-prop >hashtable [
+ [
+ [ presented set ] [
+ [ parsing-word? ] [ delimiter? ] [ symbol? ] tri
+ or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
+ foreground set
+ ] bi
+ ] bind
+ ] keep ;
+
+: string-style ( obj -- style )
+ [
+ presented set
+ COLOR: LightSalmon4 foreground set
+ ] H{ } make-assoc ;
+
+: vocab-style ( vocab -- style )
+ [
+ presented set
+ COLOR: cornsilk4 foreground set
+ ] H{ } make-assoc ;
+
+: effect-style ( effect -- style )
+ [
+ presented set
+ COLOR: DarkGreen foreground set
+ ] H{ } make-assoc ;
\ No newline at end of file
: stack-effect. ( word -- )
[ print-stack-effect? ] [ stack-effect ] bi and
- [ effect>string comment. ] when* ;
+ [ pprint-effect ] when* ;
<PRIVATE
$nl
"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-pen } "."
$nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked."
+$nl
+"A button can optionally display a message in the window's status bar whenever the mouse cursor hovers over the button. To enable this behavior, just set a string to the button's " { $snippet "tooltip" } " slot." } ;
HELP: <button>
{ $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
FROM: models => change-model ;
IN: ui.gadgets.buttons
-TUPLE: button < border pressed? selected? quot ;
+TUPLE: button < border pressed? selected? quot tooltip ;
<PRIVATE
>>pressed?
relayout-1 ;
+: button-enter ( button -- )
+ dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;
+
+: button-leave ( button -- )
+ dup "" swap show-status button-update ;
+
: button-clicked ( button -- )
dup button-update
dup button-rollover?
button H{
{ T{ button-up } [ button-clicked ] }
{ T{ button-down } [ button-update ] }
- { mouse-leave [ button-update ] }
- { mouse-enter [ button-update ] }
+ { mouse-leave [ button-leave ] }
+ { mouse-enter [ button-enter ] }
} set-gestures
: new-button ( label quot class -- button )
}
: <border-button-pen> ( -- pen )
- "button" button-background COLOR: black <border-button-state-pen> dup
- "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
+ "button" button-background button-clicked-background
+ <border-button-state-pen> dup
+ "button-clicked" button-clicked-background COLOR: white
+ <border-button-state-pen> dup dup
<button-pen> ;
: border-button-theme ( gadget -- gadget )
+ dup children>> first font>> t >>bold? drop
horizontal >>orientation
<border-button-pen> >>interior
dup dup interior>> pen-pref-dim >>min-dim
: command-button-quot ( target command -- quot )
'[ _ _ invoke-command ] ;
+: gesture>tooltip ( gesture -- str )
+ [ gesture>string "Shortcut: " prepend ] [ "Shortcut Unassigned" ] if* ;
+
: <command-button> ( target gesture command -- button )
- [ command-string swap ] keep command-button-quot
- '[ drop @ ] <border-button> ;
+ swapd [ command-name swap ] keep command-button-quot
+ '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
: <toolbar> ( target -- toolbar )
<shelf>
namespaces make opengl sequences strings splitting ui.gadgets
ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
ui.baseline-alignment ui.text colors colors.constants models
-combinators ;
+combinators opengl.gl ;
IN: ui.gadgets.labels
! A label gadget draws a string.
M: label cap-height
label-metrics cap-height>> round ;
-M: label draw-gadget*
- >label<
- [
- background get [ font-with-background ] when*
- foreground get [ font-with-foreground ] when*
- ] dip
+: draw-text* ( font text fg bg -- )
+ [ rot ] dip
+ [ font-with-background ] when* swap
+ [ font-with-foreground ] when* swap
draw-text ;
+: draw-shadowed-text ( font text -- )
+ [
+ { 0 1 } [ over shadow>> background get draw-text* ]
+ with-translation
+ ] [ foreground get transparent draw-text* ] 2bi ;
+
+: draw-normal-text ( font text -- )
+ foreground get background get draw-text* ;
+
+M: label draw-gadget*
+ >label< over shadow>>
+ [ draw-shadowed-text ] [ draw-normal-text ] if ;
+
M: label gadget-text* string>> % ;
TUPLE: label-control < label ;
ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
colors io.styles ;
-FROM: io.styles => foreground background ;
+FROM: io.styles => foreground background shadow ;
IN: ui.gadgets.panes
TUPLE: pane < track
[ font-size swap at >>size ]
[ foreground swap at >>foreground ]
[ background swap at >>background ]
+ [ shadow swap at >>shadow ]
} cleave
derive-font ;
: apply-font-style ( style gadget -- style gadget )
- { font-name font-style font-size foreground background }
+ { font-name font-style font-size foreground background shadow }
pick extract-keys specified-font >>font ;
: apply-style ( style gadget key quot -- style gadget )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.arrow
-sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
+USING: accessors calendar colors colors.constants fonts kernel
+models models.arrow models.delay sequences summary ui
+ui.gadgets ui.gadgets.labels ui.gadgets.tracks
+ui.gadgets.worlds ui.pens.solid ui.private ;
IN: ui.gadgets.status-bar
+: status-bar-font ( -- font )
+ sans-serif-font clone
+ T{ rgba f 0.216 0.243 0.282 1.0 } >>background
+ COLOR: white >>foreground ;
+
+: status-bar-theme ( label -- label )
+ status-bar-font >>font
+ T{ rgba f 0.216 0.243 0.282 1.0 } <solid> >>interior ;
+
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <arrow> <label-control>
- reverse-video-theme
+ status-bar-theme
t >>root? ;
: open-status-window ( gadget title/attributes -- )
ui.tools.browser.history ;
IN: ui.tools.browser
-TUPLE: browser-gadget < tool history pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history scroller search-field popup ;
{ 650 400 } browser-gadget set-tool-dim
dup <history> >>history
dup <search-field> >>search-field
dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> >>scroller
- dup scroller>> 1 track-add ;
+ dup dup <help-pane> { 10 0 } <border> { 1 1 } >>fill
+ <scroller> >>scroller scroller>> 1 track-add ;
M: browser-gadget graft*
[ add-definition-observer ] [ call-next-method ] bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
namespaces sets parser colors prettyprint.backend prettyprint.sections
-vocabs.parser make fry math.order ;
+prettyprint.stylesheet vocabs.parser make fry math.order ;
IN: vocabs.prettyprint
: pprint-vocab ( vocab -- )
- [ vocab-name ] [ vocab ] bi present-text ;
+ [ vocab-name ] [ vocab vocab-style ] bi styled-text ;
: pprint-in ( vocab -- )
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
"To avoid doing this in the future, add the following forms" print
"at the top of the source file:" print nl
] with-style
- { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
+ { { page-color T{ rgba f 0.94 0.94 0.91 1.0 } } }
[ manifest get pprint-manifest ] with-nesting
nl nl
] print-use-hook set-global
\ No newline at end of file