steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up UI a bit

db4
Slava Pestov 2008-06-18 22:30:54 -05:00
parent beccf83f7c
commit ce8c3cd389
14 changed files with 84 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
extra/boids/ui/ui.factor
View File

@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
"" <label> dup reverse-video-theme >population-label update-population-label
"" <label> reverse-video-theme >population-label update-population-label
"" <label> dup reverse-video-theme >cohesion-label update-cohesion-label
"" <label> dup reverse-video-theme >alignment-label update-alignment-label
"" <label> dup reverse-video-theme >separation-label update-separation-label
"" <label> reverse-video-theme >cohesion-label update-cohesion-label
"" <label> reverse-video-theme >alignment-label update-alignment-label
"" <label> reverse-video-theme >separation-label update-separation-label
<frame>

6
extra/gesture-logger/gesture-logger.factor
View File

@ -8,9 +8,9 @@ TUPLE: gesture-logger stream ;
: <gesture-logger> ( stream -- gadget )
\ gesture-logger construct-gadget
[ set-gesture-logger-stream ] keep
{ 100 100 } over set-rect-dim
dup black solid-interior ;
swap >>stream
{ 100 100 } >>dim
black solid-interior ;
M: gesture-logger handle-gesture*
drop

6
extra/lsys/ui/ui.factor
View File

@ -100,17 +100,17 @@ DEFER: empty-model
{
[ "Load" <label> dup reverse-video-theme ]
[ "Load" <label> reverse-video-theme ]
[ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
[ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
[ "Model" <label> dup reverse-video-theme ]
[ "Model" <label> reverse-video-theme ]
[ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
[ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
[ "Camera" <label> dup reverse-video-theme ]
[ "Camera" <label> reverse-video-theme ]
[ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
[ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]

29
extra/ui/gadgets/buttons/buttons.factor
View File

@ -41,7 +41,7 @@ button H{
: <button> ( gadget quot -- button )
button new
[ set-button-quot ] keep
swap >>quot
[ set-gadget-delegate ] keep ;
TUPLE: button-paint plain rollover pressed selected ;
@ -53,10 +53,10 @@ C: <button-paint> button-paint
: button-paint ( button paint -- button paint )
over find-button {
{ [ dup button-pressed? ] [ drop button-paint-pressed ] }
{ [ dup button-selected? ] [ drop button-paint-selected ] }
{ [ dup button-rollover? ] [ drop button-paint-rollover ] }
[ drop button-paint-plain ]
{ [ dup pressed?>> ] [ drop pressed>> ] }
{ [ dup selected?>> ] [ drop selected>> ] }
{ [ dup button-rollover? ] [ drop rollover>> ] }
[ drop plain>> ]
} cond ;
M: button-paint draw-interior
@ -65,25 +65,26 @@ M: button-paint draw-interior
M: button-paint draw-boundary
button-paint draw-boundary ;
: roll-button-theme ( button -- )
f black <solid> dup f <button-paint>
swap set-gadget-boundary ;
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary ; inline
: <roll-button> ( label quot -- button )
>r >label r>
<button> dup roll-button-theme ;
>r >label r> <button> roll-button-theme ;
: bevel-button-theme ( gadget -- )
: <bevel-button-paint> ( -- paint )
plain-gradient
rollover-gradient
pressed-gradient
selected-gradient
<button-paint> over set-gadget-interior
faint-boundary ;
<button-paint> ;
: bevel-button-theme ( gadget -- gadget )
<bevel-button-paint> >>interior
faint-boundary ; inline
: <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
<button> dup bevel-button-theme ;
<button> bevel-button-theme ;
TUPLE: repeat-button ;

2
extra/ui/gadgets/canvas/canvas.factor
View File

@ -9,7 +9,7 @@ TUPLE: canvas dlist ;
: <canvas> ( -- canvas )
canvas construct-gadget
dup black solid-interior ;
black solid-interior ;
: delete-canvas-dlist ( canvas -- )
dup find-gl-context

2
extra/ui/gadgets/labelled/labelled.factor
View File

@ -13,7 +13,7 @@ TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new
[
<label> dup reverse-video-theme f track,
<label> reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
] { 0 1 } build-track ;

28
extra/ui/gadgets/labels/labels.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math namespaces
USING: accessors arrays hashtables io kernel math namespaces
opengl sequences strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
@ -10,7 +10,7 @@ IN: ui.gadgets.labels
TUPLE: label text font color ;
: label-string ( label -- string )
label-text dup string? [ "\n" join ] unless ; inline
text>> dup string? [ "\n" join ] unless ; inline
: set-label-string ( string label -- )
CHAR: \n pick memq? [
@ -19,21 +19,21 @@ TUPLE: label text font color ;
set-label-text
] if ; inline
: label-theme ( gadget -- )
black over set-label-color
sans-serif-font swap set-label-font ;
: label-theme ( gadget -- gadget )
sans-serif-font >>font
black >>color ; inline
: <label> ( string -- label )
label construct-gadget
[ set-label-string ] keep
dup label-theme ;
label-theme ;
M: label pref-dim*
dup label-font open-font swap label-text text-dim ;
[ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget*
dup label-color gl-color
dup label-font swap label-text origin get draw-text ;
[ color>> gl-color ]
[ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ;
@ -45,12 +45,12 @@ M: label-control model-changed
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;
: text-theme ( gadget -- )
black over set-label-color
monospace-font swap set-label-font ;
: text-theme ( gadget -- gadget )
black >>color
monospace-font >>font ;
: reverse-video-theme ( label -- )
white over set-label-color
: reverse-video-theme ( label -- label )
white >>color
black solid-interior ;
GENERIC: >label ( obj -- gadget )

15
extra/ui/gadgets/lists/lists.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.commands ui.gestures ui.render ui.gadgets
USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
@ -27,17 +27,18 @@ TUPLE: list index presenter color hook ;
swap set-list-index ;
: list-presentation-hook ( list -- quot )
list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
[ set-presentation-hook ] keep
[ text-theme ] keep ;
swap >>hook
text-theme ; inline
: <list-items> ( list -- seq )
dup list-presentation-hook
over list-presenter
rot control-value [
[ list-presentation-hook ]
[ presenter>> ]
[ control-value ]
tri [
>r 2dup r> swap <list-presentation>
] map 2nip ;

6
extra/ui/gadgets/menus/menus.factor
View File

@ -42,11 +42,11 @@ M: menu-glass layout* gadget-child prefer ;
[ hand-clicked get find-world hide-glass ]
3append <roll-button> ;
: menu-theme ( gadget -- )
dup light-gray solid-interior
: menu-theme ( gadget -- gadget )
light-gray solid-interior
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
[
[ >r 2dup r> <menu-item> gadget, ] each 2drop
] make-filled-pile 5 <border> dup menu-theme ;
] make-filled-pile 5 <border> menu-theme ;

30
extra/ui/gadgets/panes/panes.factor
View File

@ -182,7 +182,7 @@ M: pane-stream make-span-stream
foreground [ over set-label-color ] apply-style ;
: apply-background-style ( style gadget -- style gadget )
background [ dupd solid-interior ] apply-style ;
background [ solid-interior ] apply-style ;
: specified-font ( style -- font )
[ font swap at "monospace" or ] keep
@ -207,15 +207,15 @@ M: pane-stream make-span-stream
: apply-wrap-style ( style pane -- style pane )
wrap-margin [
2dup <paragraph> swap set-pane-prototype
<paragraph> over set-pane-current
2dup <paragraph> >>prototype drop
<paragraph> >>current
] apply-style ;
: apply-border-color-style ( style gadget -- style gadget )
border-color [ dupd solid-boundary ] apply-style ;
border-color [ solid-boundary ] apply-style ;
: apply-page-color-style ( style gadget -- style gadget )
page-color [ dupd solid-interior ] apply-style ;
page-color [ solid-interior ] apply-style ;
: apply-path-style ( style gadget -- style gadget )
presented-path [ <editable-slot> ] apply-style ;
@ -224,9 +224,7 @@ M: pane-stream make-span-stream
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
presented-printer [
[ make-pane ] curry over set-editable-slot-printer
] apply-style ;
presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
@ -294,11 +292,8 @@ M: pack dispose drop ;
M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
over empty? [
2drop
] [
>r <label> dup text-theme r> add-gadget
] if ;
over empty?
[ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
M: pack stream-write gadget-write ;
@ -372,11 +367,11 @@ M: f sloppy-pick-up*
: extend-selection ( pane -- )
hand-moved? [
dup pane-selecting? [
dup selecting?>> [
dup move-caret
] [
dup hand-clicked get child? [
t over set-pane-selecting?
t >>selecting?
dup hand-clicked set-global
dup move-caret
dup caret>mark
@ -386,10 +381,9 @@ M: f sloppy-pick-up*
] when drop ;
: end-selection ( pane -- )
f over set-pane-selecting?
f >>selecting?
hand-moved? [
dup com-copy-selection
request-focus
[ com-copy-selection ] [ request-focus ] bi
] [
relayout-1
] if ;

2
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -46,7 +46,7 @@ scroller H{
y-model <y-slider> g-> set-scroller-y @right frame,
viewport,
] with-gadget
] keep t over set-gadget-root? dup faint-boundary ;
] keep t >>root? faint-boundary ;
: scroll ( value scroller -- )
[

13
extra/ui/gadgets/sliders/sliders.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models math.vectors math.functions quotations colors ;
@ -65,14 +65,15 @@ thumb H{
{ T{ drag } [ do-drag ] }
} set-gestures
: thumb-theme ( thumb -- )
plain-gradient over set-gadget-interior faint-boundary ;
: thumb-theme ( thumb -- thumb )
plain-gradient >>interior
faint-boundary ; inline
: <thumb> ( vector -- thumb )
thumb construct-gadget
t over set-gadget-root?
dup thumb-theme
[ set-gadget-orientation ] keep ;
swap >>orientation
t >>root?
thumb-theme ;
: slide-by ( amount slider -- )
gadget-model move-by ;

10
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models sequences ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
calendar ;
USING: accessors models sequences ui.gadgets.labels
ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
ui kernel calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <filter> <label-control>
dup reverse-video-theme
t over set-gadget-root? ;
reverse-video-theme
t >>root? ;
: open-status-window ( gadget title -- )
>r [

14
extra/ui/gadgets/theme/theme.factor
View File

@ -2,17 +2,17 @@
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
colors ;
colors accessors ;
IN: ui.gadgets.theme
: solid-interior ( gadget color -- )
<solid> swap set-gadget-interior ;
: solid-interior ( gadget color -- gadget )
<solid> >>interior ; inline
: solid-boundary ( gadget color -- )
<solid> swap set-gadget-boundary ;
: solid-boundary ( gadget color -- gadget )
<solid> >>boundary ; inline
: faint-boundary ( gadget -- )
gray solid-boundary ;
: faint-boundary ( gadget -- gadget )
gray solid-boundary ; inline
: selection-color ( -- color ) light-purple ;