layout alignments
parent
99edfc3593
commit
8d139c621a
|
@ -19,7 +19,6 @@
|
|||
|
||||
- #jump-f #jump-f-label
|
||||
- extract word inside M:, C:, and structure browsing for these
|
||||
- fix checkbox alignment
|
||||
- each-slot combinator
|
||||
- references primitive
|
||||
- fix completion invoke in middle of word
|
||||
|
|
|
@ -66,8 +66,8 @@ USE: words
|
|||
: make-shapes ( -- )
|
||||
f world get set-gadget-children
|
||||
|
||||
default-gap <pile> "pile" set
|
||||
default-gap <shelf> "shelf" set
|
||||
0 default-gap <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
|
||||
|
|
|
@ -75,7 +75,7 @@ TUPLE: checkbox bevel selected? delegate ;
|
|||
update-checkbox ;
|
||||
|
||||
C: checkbox ( label -- checkbox )
|
||||
default-gap <shelf> over set-checkbox-delegate
|
||||
<default-shelf> over set-checkbox-delegate
|
||||
[ >r <label> r> add-gadget ] keep
|
||||
[ f bevel-border swap init-checkbox-bevel ] keep
|
||||
dup [ toggle-checkbox ] button-actions
|
||||
|
|
|
@ -4,8 +4,6 @@ IN: gadgets
|
|||
USING: generic kernel lists math namespaces sdl line-editor
|
||||
strings ;
|
||||
|
||||
TUPLE: field active? editor delegate ;
|
||||
|
||||
TUPLE: editor line caret delegate ;
|
||||
|
||||
: editor-text ( editor -- text )
|
||||
|
@ -69,32 +67,35 @@ M: editor layout* ( field -- )
|
|||
M: editor draw-shape ( label -- )
|
||||
dup [ editor-text draw-shape ] with-translation ;
|
||||
|
||||
TUPLE: field active? editor delegate ;
|
||||
|
||||
: with-editor ( editor quot -- )
|
||||
swap [ editor-line swap bind ] keep relayout ; inline
|
||||
|
||||
: set-caret-x ( x editor -- )
|
||||
#! Move the caret to a clicked location.
|
||||
[ line-text get x>offset caret set ] with-editor ;
|
||||
|
||||
: click-editor ( editor -- )
|
||||
my-hand
|
||||
2dup relative-pos shape-x pick set-caret-x
|
||||
request-focus ;
|
||||
|
||||
: field-border ( gadget -- border )
|
||||
bevel-border dup f bevel-up? set-paint-property ;
|
||||
|
||||
: with-field-editor ( field quot -- )
|
||||
swap field-editor [ editor-line swap bind ] keep relayout ;
|
||||
|
||||
M: field user-input* ( ch field -- ? )
|
||||
[ insert-char ] with-field-editor f ;
|
||||
|
||||
: set-caret-x ( x field -- )
|
||||
#! Move the caret to a clicked location.
|
||||
[ line-text get x>offset caret set ] with-field-editor ;
|
||||
|
||||
: click-field ( field -- )
|
||||
my-hand dup shape-x pick field-editor screen-pos shape-x -
|
||||
pick set-caret-x request-focus ;
|
||||
field-editor [ insert-char ] with-editor f ;
|
||||
|
||||
: field-gestures ( -- hash )
|
||||
{{
|
||||
[[ [ gain-focus ] [ field-editor focus-editor ] ]]
|
||||
[[ [ lose-focus ] [ field-editor unfocus-editor ] ]]
|
||||
[[ [ button-down 1 ] [ click-field ] ]]
|
||||
[[ [ "BACKSPACE" ] [ [ backspace ] with-field-editor ] ]]
|
||||
[[ [ "LEFT" ] [ [ left ] with-field-editor ] ]]
|
||||
[[ [ "RIGHT" ] [ [ right ] with-field-editor ] ]]
|
||||
[[ [ "CTRL" "k" ] [ [ line-clear ] with-field-editor ] ]]
|
||||
[[ [ button-down 1 ] [ field-editor click-editor ] ]]
|
||||
[[ [ "BACKSPACE" ] [ field-editor [ backspace ] with-editor ] ]]
|
||||
[[ [ "LEFT" ] [ field-editor [ left ] with-editor ] ]]
|
||||
[[ [ "RIGHT" ] [ field-editor [ right ] with-editor ] ]]
|
||||
[[ [ "CTRL" "k" ] [ field-editor [ line-clear ] with-editor ] ]]
|
||||
}} ;
|
||||
|
||||
C: field ( text -- field )
|
||||
|
|
|
@ -80,20 +80,8 @@ C: gadget ( shape -- gadget )
|
|||
: each-parent ( gadget quot -- ? )
|
||||
>r parent-list r> (each-parent) ; inline
|
||||
|
||||
! : each-parent ( gadget quot -- ? )
|
||||
! #! Apply quotation to each parent of the gadget in turn,
|
||||
! #! stopping when the quotation returns f. Return f if a
|
||||
! #! quotation somewhere returned f; if the search bottoms
|
||||
! #! out, return t.
|
||||
! over [
|
||||
! [ call ] 2keep rot [
|
||||
! >r gadget-parent r> each-parent
|
||||
! ] [
|
||||
! 2drop f ( quotation returns f )
|
||||
! ] ifte
|
||||
! ] [
|
||||
! 2drop t ( search bottomed out )
|
||||
! ] ifte ; inline
|
||||
: relative-pos ( g1 g2 -- g2-p1 )
|
||||
shape-pos swap screen-pos - ;
|
||||
|
||||
: screen-pos ( gadget -- point )
|
||||
#! The position of the gadget on the screen.
|
||||
|
|
|
@ -24,32 +24,48 @@ M: gadget layout* drop ;
|
|||
: default-gap 3 ;
|
||||
|
||||
! A pile is a box that lays out its contents vertically.
|
||||
TUPLE: pile gap delegate ;
|
||||
TUPLE: pile align gap delegate ;
|
||||
|
||||
C: pile ( gap -- pile )
|
||||
C: pile ( align gap -- pile )
|
||||
0 0 0 0 <rectangle> <gadget> over set-pile-delegate
|
||||
[ set-pile-gap ] keep ;
|
||||
[ set-pile-gap ] keep
|
||||
[ set-pile-align ] keep ;
|
||||
|
||||
: <default-pile> ( -- pile )
|
||||
1/2 default-gap <pile> ;
|
||||
|
||||
: horizontal-layout ( gadget y box -- )
|
||||
pick shape-w over shape-w swap - swap pile-align * >fixnum
|
||||
swap rot move-gadget ;
|
||||
|
||||
M: pile layout* ( pile -- )
|
||||
dup pile-gap over gadget-children run-heights >r >r
|
||||
dup gadget-children max-width r> pick resize-gadget
|
||||
gadget-children r> zip [
|
||||
uncons 0 swap rot move-gadget
|
||||
] each ;
|
||||
dup gadget-children r> zip [
|
||||
uncons rot horizontal-layout
|
||||
] each-with ;
|
||||
|
||||
! A shelf is a box that lays out its contents horizontally.
|
||||
TUPLE: shelf gap delegate ;
|
||||
TUPLE: shelf gap align delegate ;
|
||||
|
||||
C: shelf ( gap -- pile )
|
||||
C: shelf ( align gap -- shelf )
|
||||
0 0 0 0 <rectangle> <gadget> over set-shelf-delegate
|
||||
[ set-shelf-gap ] keep ;
|
||||
[ set-shelf-gap ] keep
|
||||
[ set-shelf-align ] keep ;
|
||||
|
||||
: vertical-layout ( gadget x box -- )
|
||||
pick shape-h over shape-h swap - swap shelf-align * >fixnum
|
||||
rot move-gadget ;
|
||||
|
||||
: <default-shelf> ( -- shelf )
|
||||
1/2 default-gap <shelf> ;
|
||||
|
||||
M: shelf layout* ( pile -- )
|
||||
dup shelf-gap over gadget-children run-widths >r >r
|
||||
dup gadget-children max-height r> swap pick resize-gadget
|
||||
gadget-children r> zip [
|
||||
uncons 0 rot move-gadget
|
||||
] each ;
|
||||
dup gadget-children r> zip [
|
||||
uncons pick vertical-layout
|
||||
] each drop ;
|
||||
|
||||
! A border lays out its children on top of each other, all with
|
||||
! a 5-pixel padding.
|
||||
|
|
Loading…
Reference in New Issue