UI work
Slava Pestov
parent
779db3970d
commit
e9ea91918d
|
|
@ -6,14 +6,11 @@
|
|||
|
||||
+ ui:
|
||||
|
||||
- inspector: complain if UI not running
|
||||
- opening listeners fails
|
||||
- mouse enter onto overlapping with interior, but not child, gadget
|
||||
- menu dragging
|
||||
- hide menu after item selected
|
||||
- scrollable inspector
|
||||
- inspector needs prettier nesting
|
||||
- <titled> needs to look better
|
||||
- enforce inspector uniqueness
|
||||
- auto-updating inspector
|
||||
- fix up the min thumb size hack
|
||||
- fix up initial layout of slider
|
||||
|
|
@ -23,6 +20,7 @@
|
|||
- resizing and moving gadgets
|
||||
- faster layout
|
||||
- faster repaint
|
||||
- closing inspectors
|
||||
|
||||
+ compiler/ffi:
|
||||
|
||||
|
|
|
|||
|
|
@ -1,80 +0,0 @@
|
|||
! TrueType font rendering demo.
|
||||
!
|
||||
! To run this code, bootstrap Factor like so:
|
||||
!
|
||||
! ./f boot.image.le32
|
||||
! -libraries:sdl:name=libSDL.so
|
||||
! -libraries:sdl-gfx:name=libSDL_gfx.so
|
||||
! -libraries:sdl-ttf:name=libSDL_ttf.so
|
||||
!
|
||||
! (But all on one line)
|
||||
!
|
||||
! Then, start Factor as usual (./f factor.image) and enter this
|
||||
! at the listener:
|
||||
!
|
||||
! "examples/text-demo.factor" run-file
|
||||
|
||||
IN: text-demo
|
||||
USING: listener parser threads unparser ;
|
||||
USE: streams
|
||||
USE: sdl
|
||||
USE: sdl-event
|
||||
USE: sdl-gfx
|
||||
USE: sdl-video
|
||||
USE: sdl-ttf
|
||||
USE: namespaces
|
||||
USE: math
|
||||
USE: kernel
|
||||
USE: test
|
||||
USE: compiler
|
||||
USE: strings
|
||||
USE: alien
|
||||
USE: prettyprint
|
||||
USE: lists
|
||||
USE: gadgets
|
||||
USE: generic
|
||||
USE: stdio
|
||||
USE: prettyprint
|
||||
USE: words
|
||||
|
||||
: filled? "filled" get checkbox-selected? ;
|
||||
|
||||
: <funny-rect>
|
||||
filled? [ <plain-rect> ] [ <hollow-rect> ] ifte <gadget> dup moving-actions ;
|
||||
|
||||
: <funny-ellipse>
|
||||
filled? [ <plain-ellipse> ] [ <hollow-ellipse> ] ifte <gadget> dup moving-actions ;
|
||||
|
||||
: <funny-line>
|
||||
<line> <gadget> dup moving-actions ;
|
||||
|
||||
|
||||
: make-shapes ( -- )
|
||||
f world get set-gadget-children
|
||||
|
||||
0 default-gap 0 <pile> "pile" set
|
||||
<default-shelf> "shelf" set
|
||||
! "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget
|
||||
! "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
|
||||
! "New Ellipse" [ drop 100 100 200 100 <funny-ellipse> dup [ 0 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
|
||||
! "New Line" [ drop 100 100 200 100 <funny-line> dup [ 255 0 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
|
||||
! "Prompt" [ drop "Enter input text:" input-dialog . flush ] <button> "shelf" get add-gadget
|
||||
! "Filled?" <checkbox> dup "filled" set "shelf" get add-gadget
|
||||
! "shelf" get "pile" get add-gadget
|
||||
! "Welcome to Factor " version cat2 <label> "pile" get add-gadget
|
||||
! "A field." <field> "pile" get add-gadget
|
||||
! "Another field." <field> "pile" get add-gadget
|
||||
<console-pane> <scroller> "pile" get add-gadget
|
||||
|
||||
"pile" get line-border dup "dialog" set dup
|
||||
moving-actions
|
||||
world get add-gadget
|
||||
|
||||
;
|
||||
|
||||
: gadget-demo ( -- )
|
||||
make-shapes
|
||||
USE: shells
|
||||
ui ;
|
||||
|
||||
gadget-demo
|
||||
|
|
@ -177,6 +177,7 @@ cpu "x86" = "mini" get not and [
|
|||
"/library/ui/halo.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
"/library/ui/checkboxes.factor"
|
||||
"/library/ui/line-editor.factor"
|
||||
"/library/ui/editors.factor"
|
||||
"/library/ui/dialogs.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 ;
|
||||
USING: generic kernel lists math namespaces prettyprint sdl
|
||||
stdio ;
|
||||
|
||||
: button-down? ( n -- ? )
|
||||
my-hand hand-buttons contains? ;
|
||||
|
|
@ -22,6 +23,7 @@ USING: generic kernel lists math namespaces sdl ;
|
|||
] ifte ;
|
||||
|
||||
: button-update ( button -- )
|
||||
dup dup mouse-over? rollover? set-paint-property
|
||||
dup dup button-pressed? reverse-video set-paint-property
|
||||
redraw ;
|
||||
|
||||
|
|
@ -44,43 +46,10 @@ USING: generic kernel lists math namespaces sdl ;
|
|||
: <button> ( label quot -- button )
|
||||
>r <label> line-border dup r> button-actions ;
|
||||
|
||||
: <check> ( w h -- cross )
|
||||
2dup >r >r 0 0 r> r> <line> <gadget>
|
||||
>r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
|
||||
2list <stack> ;
|
||||
: roll-border ( child -- border )
|
||||
0 0 0 0 <roll-rect> <gadget> 1 <border> ;
|
||||
|
||||
TUPLE: checkbox bevel selected? delegate ;
|
||||
|
||||
: init-checkbox-bevel ( bevel checkbox -- )
|
||||
2dup set-checkbox-bevel add-gadget ;
|
||||
|
||||
: update-checkbox ( checkbox -- )
|
||||
#! Really, there should only be one child.
|
||||
dup checkbox-bevel gadget-children [ unparent ] each
|
||||
dup checkbox-selected? [
|
||||
7 7 <check>
|
||||
] [
|
||||
0 0 7 7 <rectangle> <gadget>
|
||||
] ifte swap checkbox-bevel add-gadget ;
|
||||
|
||||
: toggle-checkbox ( checkbox -- )
|
||||
dup checkbox-selected? not over set-checkbox-selected?
|
||||
update-checkbox ;
|
||||
|
||||
: checkbox-update ( checkbox -- )
|
||||
dup button-pressed? >r checkbox-bevel r>
|
||||
reverse-video set-paint-property ;
|
||||
|
||||
: checkbox-actions ( checkbox -- )
|
||||
dup [ toggle-checkbox ] [ action ] set-action
|
||||
dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
|
||||
dup [ checkbox-update ] [ button-down 1 ] set-action
|
||||
dup [ checkbox-update ] [ mouse-leave ] set-action
|
||||
[ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
|
||||
|
||||
C: checkbox ( label -- checkbox )
|
||||
<default-shelf> over set-checkbox-delegate
|
||||
[ f line-border swap init-checkbox-bevel ] keep
|
||||
[ >r <label> r> add-gadget ] keep
|
||||
dup checkbox-actions
|
||||
dup update-checkbox ;
|
||||
: <roll-button> ( label quot -- gadget )
|
||||
#! Thinner border that is only visible when the mouse is
|
||||
#! over the button.
|
||||
>r <label> roll-border dup r> button-actions ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel lists math namespaces sdl ;
|
||||
|
||||
: <check> ( w h -- cross )
|
||||
2dup >r >r 0 0 r> r> <line> <gadget>
|
||||
>r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
|
||||
2list <stack> ;
|
||||
|
||||
TUPLE: checkbox bevel selected? delegate ;
|
||||
|
||||
: init-checkbox-bevel ( bevel checkbox -- )
|
||||
2dup set-checkbox-bevel add-gadget ;
|
||||
|
||||
: update-checkbox ( checkbox -- )
|
||||
#! Really, there should only be one child.
|
||||
dup checkbox-bevel gadget-children [ unparent ] each
|
||||
dup checkbox-selected? [
|
||||
7 7 <check>
|
||||
] [
|
||||
0 0 7 7 <rectangle> <gadget>
|
||||
] ifte swap checkbox-bevel add-gadget ;
|
||||
|
||||
: toggle-checkbox ( checkbox -- )
|
||||
dup checkbox-selected? not over set-checkbox-selected?
|
||||
update-checkbox ;
|
||||
|
||||
: checkbox-update ( checkbox -- )
|
||||
dup button-pressed? >r checkbox-bevel r>
|
||||
reverse-video set-paint-property ;
|
||||
|
||||
: checkbox-actions ( checkbox -- )
|
||||
dup [ toggle-checkbox ] [ action ] set-action
|
||||
dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
|
||||
dup [ checkbox-update ] [ button-down 1 ] set-action
|
||||
dup [ checkbox-update ] [ mouse-leave ] set-action
|
||||
[ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
|
||||
|
||||
C: checkbox ( label -- checkbox )
|
||||
<default-shelf> over set-checkbox-delegate
|
||||
[ f line-border swap init-checkbox-bevel ] keep
|
||||
[ >r <label> r> add-gadget ] keep
|
||||
dup checkbox-actions
|
||||
dup update-checkbox ;
|
||||
|
|
@ -1,12 +1,18 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: gadgets generic hashtables kernel kernel-internals lists
|
||||
namespaces unparser vectors words ;
|
||||
USING: errors gadgets generic hashtables kernel kernel-internals
|
||||
lists namespaces strings unparser vectors words ;
|
||||
|
||||
: label-box ( list -- gadget )
|
||||
<line-pile> swap [ <presentation> over add-gadget ] each ;
|
||||
|
||||
: unparse* ( obj -- str ) dup string? [ unparse ] unless ;
|
||||
|
||||
: sort-sheet ( assoc -- assoc )
|
||||
#! Sort an association list whose keys are arbitrary objects
|
||||
[ 2car swap unparse* swap unparse* str-lexi> ] sort ;
|
||||
|
||||
: alist>sheet ( assoc -- sheet )
|
||||
unzip swap
|
||||
<default-shelf>
|
||||
|
|
@ -28,7 +34,7 @@ namespaces unparser vectors words ;
|
|||
] map-with ;
|
||||
|
||||
: slot-sheet ( obj -- sheet )
|
||||
object>alist alist>sheet "Slots:" <titled> ;
|
||||
object>alist sort-sheet alist>sheet "Slots:" <titled> ;
|
||||
|
||||
GENERIC: custom-sheet ( obj -- gadget )
|
||||
|
||||
|
|
@ -36,7 +42,8 @@ GENERIC: custom-sheet ( obj -- gadget )
|
|||
0 default-gap 0 <pile>
|
||||
over top-sheet over add-gadget
|
||||
over slot-sheet over add-gadget
|
||||
swap custom-sheet over add-gadget ;
|
||||
swap custom-sheet over add-gadget
|
||||
line-border dup moving-actions ;
|
||||
|
||||
M: object custom-sheet drop <empty-gadget> ;
|
||||
|
||||
|
|
@ -50,7 +57,7 @@ M: vector custom-sheet ( array -- gadget )
|
|||
"Elements:" <titled> ;
|
||||
|
||||
M: hashtable custom-sheet ( array -- gadget )
|
||||
hash>alist alist>sheet "Entries:" <titled> ;
|
||||
hash>alist sort-sheet alist>sheet "Entries:" <titled> ;
|
||||
|
||||
M: word custom-sheet ( word -- gadget )
|
||||
word-props <inspector> empty-border "Properties:" <titled> ;
|
||||
|
|
@ -62,7 +69,25 @@ M: tuple custom-sheet ( tuple -- gadget )
|
|||
<empty-gadget>
|
||||
] ifte* ;
|
||||
|
||||
: inspect ( obj -- )
|
||||
<inspector> ( <scroller> )
|
||||
line-border dup moving-actions world get add-gadget ;
|
||||
! We ensure that only one inspector is open for each object.
|
||||
SYMBOL: inspectors
|
||||
|
||||
: ensure-ui
|
||||
world get dup [ world-running? ] when [
|
||||
"Inspector cannot be used if UI not running." throw
|
||||
] unless ;
|
||||
|
||||
: inspector ( obj -- gadget )
|
||||
#! Return an existing inspector gadget for this object, or
|
||||
#! create a new one.
|
||||
dup inspectors get assq [
|
||||
dup <inspector>
|
||||
[ swap inspectors [ acons ] change ] keep
|
||||
] ?unless ;
|
||||
|
||||
: inspect ( obj -- )
|
||||
#! Show an inspector for the object. The inspector lists
|
||||
#! slots and entries in collections.
|
||||
ensure-ui global [ inspector world get add-gadget ] bind ;
|
||||
|
||||
global [ inspectors off ] bind
|
||||
|
|
|
|||
|
|
@ -10,16 +10,6 @@ C: label ( text -- )
|
|||
<empty-gadget> over set-label-delegate
|
||||
[ set-label-text ] keep ;
|
||||
|
||||
: update-rollover ( gadget -- )
|
||||
dup dup my-hand hand-gadget child?
|
||||
rollover? set-paint-property redraw ;
|
||||
|
||||
: <roll-label> ( text -- )
|
||||
#! A label that shows an outline when the mouse is over it.
|
||||
<label> 0 0 0 0 <roll-rect> <gadget> over set-label-delegate
|
||||
dup [ update-rollover ] [ mouse-enter ] set-action
|
||||
dup [ update-rollover ] [ mouse-leave ] set-action ;
|
||||
|
||||
M: label layout* ( label -- )
|
||||
[ label-text dup shape-w swap shape-h ] keep resize-gadget ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,11 +3,13 @@
|
|||
IN: gadgets
|
||||
USING: kernel lists math namespaces ;
|
||||
|
||||
: hide-menu ( world -- )
|
||||
: hide-menu ( -- )
|
||||
world get
|
||||
dup world-menu [ unparent ] when* f swap set-world-menu ;
|
||||
|
||||
: show-menu ( menu -- )
|
||||
world get dup hide-menu
|
||||
hide-menu
|
||||
world get
|
||||
2dup set-world-menu
|
||||
2dup world-hand screen-pos >rect rot move-gadget
|
||||
add-gadget ;
|
||||
|
|
@ -21,14 +23,20 @@ USING: kernel lists math namespaces ;
|
|||
TUPLE: menu delegate ;
|
||||
|
||||
: menu-actions ( menu -- )
|
||||
[ drop world get hide-menu ] [ button-up 1 ] set-action ;
|
||||
[ drop world get hide-menu ] [ button-down 1 ] set-action ;
|
||||
|
||||
: assoc>menu ( assoc menu -- )
|
||||
#! Given an association list mapping labels to quotations.
|
||||
#! Prepend a call to hide-menu to each quotation.
|
||||
[
|
||||
uncons \ hide-menu swons <menu-item> swap add-gadget
|
||||
] each-with ;
|
||||
|
||||
C: menu ( assoc -- gadget )
|
||||
#! Given an association list mapping labels to quotations.
|
||||
[ f line-border swap set-menu-delegate ] keep
|
||||
<line-pile> [ swap add-gadget ] 2keep
|
||||
rot [ uncons <menu-item> swap add-gadget ] each-with
|
||||
dup menu-actions ;
|
||||
rot assoc>menu dup menu-actions ;
|
||||
|
||||
! While a menu is open, clicking anywhere sends the click to
|
||||
! the menu.
|
||||
|
|
|
|||
|
|
@ -35,8 +35,12 @@ TUPLE: hollow-rect delegate ;
|
|||
C: hollow-rect ( x y w h -- rect )
|
||||
[ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
|
||||
|
||||
: hollow-rect ( shape -- )
|
||||
#! Draw a hollow rect with the bounds of an arbitrary shape.
|
||||
rect>screen >r 1 - r> 1 - fg rgb rectangleColor ;
|
||||
|
||||
M: hollow-rect draw-shape ( rect -- )
|
||||
>r surface get r> rect>screen fg rgb rectangleColor ;
|
||||
>r surface get r> hollow-rect ;
|
||||
|
||||
! A rectangle that is filled.
|
||||
TUPLE: plain-rect delegate ;
|
||||
|
|
@ -44,8 +48,12 @@ TUPLE: plain-rect delegate ;
|
|||
C: plain-rect ( x y w h -- rect )
|
||||
[ >r <rectangle> r> set-plain-rect-delegate ] keep ;
|
||||
|
||||
: plain-rect ( shape -- )
|
||||
#! Draw a filled rect with the bounds of an arbitrary shape.
|
||||
rect>screen bg rgb boxColor ;
|
||||
|
||||
M: plain-rect draw-shape ( rect -- )
|
||||
>r surface get r> rect>screen bg rgb boxColor ;
|
||||
>r surface get r> plain-rect ;
|
||||
|
||||
! A rectangle that is filled, and has a visible outline.
|
||||
TUPLE: etched-rect delegate ;
|
||||
|
|
@ -54,9 +62,7 @@ C: etched-rect ( x y w h -- rect )
|
|||
[ >r <rectangle> r> set-etched-rect-delegate ] keep ;
|
||||
|
||||
M: etched-rect draw-shape ( rect -- )
|
||||
>r surface get r> 2dup
|
||||
rect>screen bg rgb boxColor
|
||||
rect>screen fg rgb rectangleColor ;
|
||||
>r surface get r> 2dup plain-rect hollow-rect ;
|
||||
|
||||
! A rectangle that has a visible outline only if the rollover
|
||||
! paint property is set.
|
||||
|
|
@ -68,11 +74,8 @@ C: roll-rect ( x y w h -- rect )
|
|||
[ >r <rectangle> r> set-roll-rect-delegate ] keep ;
|
||||
|
||||
M: roll-rect draw-shape ( rect -- )
|
||||
rollover? get [
|
||||
>r surface get r> rect>screen fg rgb rectangleColor
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
>r surface get r> 2dup
|
||||
plain-rect rollover? get [ hollow-rect ] [ 2drop ] ifte ;
|
||||
|
||||
M: line draw-shape ( line -- )
|
||||
>r surface get r>
|
||||
|
|
@ -136,8 +139,8 @@ SYMBOL: clip
|
|||
: screen-bounds ( shape -- rect )
|
||||
[ shape-x x get + ] keep
|
||||
[ shape-y y get + ] keep
|
||||
[ shape-w 1 + ] keep
|
||||
shape-h 1 +
|
||||
[ shape-w ] keep
|
||||
shape-h
|
||||
<rectangle> ;
|
||||
|
||||
: clip-rect ( x1 x2 y1 y2 -- rect )
|
||||
|
|
|
|||
|
|
@ -78,5 +78,7 @@ M: pane stream-close ( stream -- ) drop ;
|
|||
|
||||
: <console-pane> ( -- pane )
|
||||
<pane> dup [
|
||||
[ print-banner listener ] in-thread
|
||||
[
|
||||
clear print-banner listener
|
||||
] in-thread
|
||||
] with-stream ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: kernel lists unparser ;
|
||||
USING: kernel lists namespaces prettyprint stdio unparser ;
|
||||
|
||||
DEFER: inspect
|
||||
|
||||
|
|
@ -15,15 +15,14 @@ DEFER: inspect
|
|||
[[ "Inspect" [ inspect ] ]]
|
||||
] actionize ;
|
||||
|
||||
TUPLE: presentation object delegate ;
|
||||
: press-presentation ( presentation obj -- )
|
||||
#! Called when mouse is pressed over a presentation.
|
||||
swap button-update object-menu <menu> show-menu ;
|
||||
|
||||
: presentation-actions ( presentation -- )
|
||||
dup
|
||||
[ drop ] [ button-up 1 ] set-action
|
||||
[ presentation-object object-menu <menu> show-menu ]
|
||||
: presentation-actions ( presentation obj -- )
|
||||
[ literal, \ press-presentation , ] make-list
|
||||
[ button-down 1 ] set-action ;
|
||||
|
||||
C: presentation ( obj -- gadget )
|
||||
over unparse <roll-label> over set-presentation-delegate
|
||||
[ set-presentation-object ] keep
|
||||
dup presentation-actions ;
|
||||
: <presentation> ( obj -- gadget )
|
||||
dup unparse [ drop ] <roll-button>
|
||||
[ swap presentation-actions ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,18 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: kernel memory namespaces ;
|
||||
USING: kernel memory namespaces stdio ;
|
||||
|
||||
SYMBOL: root-menu
|
||||
|
||||
: show-root-menu ( -- )
|
||||
root-menu get <menu> show-menu ;
|
||||
|
||||
: <console> ( -- console )
|
||||
<console-pane> <scroller> line-border dup moving-actions ;
|
||||
|
||||
[
|
||||
[[ "Listener" [ <console-pane> <scroller> world get add-gadget ] ]]
|
||||
[[ "Listener" [ <console> world get add-gadget ] ]]
|
||||
[[ "Globals" [ global inspect ] ]]
|
||||
[[ "Save image" [ "image" get save-image ] ]]
|
||||
[[ "Exit" [ f world get set-world-running? ] ]]
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: alien generic kernel lists math memory namespaces sdl
|
||||
sdl-event sdl-video stdio strings threads ;
|
||||
USING: alien errors generic kernel lists math memory namespaces
|
||||
sdl sdl-event sdl-video stdio strings threads ;
|
||||
|
||||
! The world gadget is the top level gadget that all (visible)
|
||||
! gadgets are contained in. The current world is stored in the
|
||||
|
|
@ -56,6 +56,12 @@ DEFER: handle-event
|
|||
drop world get world-step [ yield run-world ] when
|
||||
] ifte ;
|
||||
|
||||
: ensure-ui ( -- )
|
||||
#! Raise an error if the UI is not running.
|
||||
world get dup [ world-running? ] when [
|
||||
"Inspector cannot be used if UI not running." throw
|
||||
] unless ;
|
||||
|
||||
global [
|
||||
|
||||
<world> world set
|
||||
|
|
|
|||
Loading…
Reference in New Issue