arrows in the UI, and various cleanups
Slava Pestov
parent
8ea8d65c1f
commit
b9165cd02c
|
|
@ -17,11 +17,15 @@
|
|||
|
||||
+ ui:
|
||||
|
||||
- tabular output
|
||||
- arrows in outliner and scrollbars
|
||||
- completion
|
||||
- debugger should use outlining
|
||||
- support nested incremental layouts more efficiently
|
||||
- make-pane should not need world-theme
|
||||
- fix up the min thumb size hack
|
||||
- long lines of text fail in draw-surface
|
||||
- only redraw dirty gadgets
|
||||
- faster mouse tracking
|
||||
- off-by-one error in pick-up?
|
||||
- closing ui does not stop timers
|
||||
- adding/removing timers automatically for animated gadgets
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@ M: general-list tutorial-line
|
|||
|
||||
: <page> ( list -- gadget )
|
||||
[ tutorial-line ] map
|
||||
<pile> 1 over set-pack-fill [ add-gadgets ] keep
|
||||
empty-border ;
|
||||
make-pile 1 over set-pack-fill
|
||||
gap-border ;
|
||||
|
||||
: tutorial-pages
|
||||
[
|
||||
|
|
|
|||
|
|
@ -3,12 +3,14 @@
|
|||
IN: styles
|
||||
|
||||
! Colors are RGB triples.
|
||||
: black @{ 0 0 0 }@ ;
|
||||
: gray @{ 128 128 128 }@ ;
|
||||
: white @{ 255 255 255 }@ ;
|
||||
: red @{ 255 0 0 }@ ;
|
||||
: green @{ 0 255 0 }@ ;
|
||||
: blue @{ 0 0 255 }@ ;
|
||||
: black @{ 0 0 0 }@ ;
|
||||
: dark-gray @{ 64 64 64 }@ ;
|
||||
: gray @{ 128 128 128 }@ ;
|
||||
: light-gray @{ 192 192 192 }@ ;
|
||||
: white @{ 255 255 255 }@ ;
|
||||
: red @{ 255 0 0 }@ ;
|
||||
: green @{ 0 255 0 }@ ;
|
||||
: blue @{ 0 0 255 }@ ;
|
||||
|
||||
SYMBOL: foreground ! Used for text and outline shapes.
|
||||
SYMBOL: background ! Used for filled shapes.
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ USE: memory
|
|||
|
||||
[ t ] [
|
||||
[ "Hello" throw ] catch drop
|
||||
global [ "error" get ] bind
|
||||
global [ error get ] bind
|
||||
"Hello" =
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ USING: generic inspector kernel kernel-internals lists math
|
|||
namespaces parser prettyprint sequences io sequences-internals
|
||||
strings vectors words ;
|
||||
|
||||
SYMBOL: error
|
||||
SYMBOL: error-continuation
|
||||
|
||||
: expired-error. ( obj -- )
|
||||
"Object did not survive image save/load: " write . ;
|
||||
|
||||
|
|
@ -100,10 +103,12 @@ M: string error. ( error -- ) print ;
|
|||
|
||||
M: object error. ( error -- ) . ;
|
||||
|
||||
: :s ( -- ) "error-datastack" get stack. ;
|
||||
: :r ( -- ) "error-callstack" get stack. ;
|
||||
: :s ( -- ) error-continuation get continuation-data stack. ;
|
||||
|
||||
: :get ( var -- value ) "error-namestack" get (get) ;
|
||||
: :r ( -- ) error-continuation get continuation-call stack. ;
|
||||
|
||||
: :get ( var -- value )
|
||||
error-continuation get continuation-name (get) ;
|
||||
|
||||
: debug-help ( -- )
|
||||
":s :r show stacks at time of error." print
|
||||
|
|
@ -122,21 +127,10 @@ M: object error. ( error -- ) . ;
|
|||
#! and return to the caller.
|
||||
[ print-error debug-help ] recover ;
|
||||
|
||||
: save-error ( error ds rs ns cs -- )
|
||||
#! Save the stacks and parser state for post-mortem
|
||||
#! inspection after an error.
|
||||
global [
|
||||
"error-catchstack" set
|
||||
"error-namestack" set
|
||||
"error-callstack" set
|
||||
"error-datastack" set
|
||||
"error" set
|
||||
] bind ;
|
||||
: save-error ( error continuation -- )
|
||||
global [ error-continuation set error set ] bind ;
|
||||
|
||||
: init-error-handler ( -- )
|
||||
( kernel calls on error )
|
||||
[
|
||||
datastack dupd callstack namestack catchstack
|
||||
save-error rethrow
|
||||
] 5 setenv
|
||||
[ dup continuation save-error rethrow ] 5 setenv
|
||||
kernel-error 12 setenv ;
|
||||
|
|
|
|||
|
|
@ -51,9 +51,6 @@ DEFER: describe
|
|||
#! Outlining word browser.
|
||||
vocabs [ f over [ words. ] curry write-outliner ] each ;
|
||||
|
||||
: stack. ( seq -- seq )
|
||||
reverse-slice >array describe ;
|
||||
|
||||
: usage. ( word -- )
|
||||
#! Outlining usages browser.
|
||||
usage [ usage. ] object-outline ;
|
||||
|
|
@ -62,5 +59,8 @@ DEFER: describe
|
|||
#! Outlining call hierarchy browser.
|
||||
uses [ uses. ] object-outline ;
|
||||
|
||||
: stack. ( seq -- seq )
|
||||
reverse-slice >array describe ;
|
||||
|
||||
: .s datastack stack. ;
|
||||
: .r callstack stack. ;
|
||||
|
|
|
|||
|
|
@ -2,24 +2,17 @@
|
|||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-books
|
||||
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
|
||||
generic kernel lists math matrices sequences ;
|
||||
generic kernel lists math matrices namespaces sequences ;
|
||||
|
||||
TUPLE: book page ;
|
||||
|
||||
C: book ( pages -- book )
|
||||
<gadget> over set-delegate
|
||||
0 over set-book-page
|
||||
[ add-gadgets ] keep ;
|
||||
|
||||
M: book pref-dim ( book -- dim )
|
||||
gadget-children [ pref-dim ] map @{ 0 0 0 }@ [ vmax ] reduce ;
|
||||
<stack> over set-delegate
|
||||
0 over set-book-page [ add-gadgets ] keep ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rect-dim over gadget-children [
|
||||
f over set-gadget-visible?
|
||||
@{ 0 0 0 }@ over set-rect-loc
|
||||
set-gadget-dim
|
||||
] each-with
|
||||
dup delegate layout*
|
||||
dup gadget-children [ f swap set-gadget-visible? ] each
|
||||
dup book-page swap gadget-children nth
|
||||
[ t swap set-gadget-visible? ] when* ;
|
||||
|
||||
|
|
@ -42,12 +35,11 @@ TUPLE: book-browser book ;
|
|||
|
||||
: <book-buttons> ( book -- gadget )
|
||||
[
|
||||
{ "|<" [ find-book first-page ] }
|
||||
{ "<" [ find-book prev-page ] }
|
||||
{ ">" [ find-book next-page ] }
|
||||
{ ">|" [ find-book last-page ] }
|
||||
] [ first2 >r <label> r> <button> ] map
|
||||
<shelf> [ add-gadgets ] keep ;
|
||||
|left <polygon-gadget> [ find-book first-page ] <button> ,
|
||||
left <polygon-gadget> [ find-book prev-page ] <button> ,
|
||||
right <polygon-gadget> [ find-book next-page ] <button> ,
|
||||
right| <polygon-gadget> [ find-book last-page ] <button> ,
|
||||
] { } make make-shelf ;
|
||||
|
||||
C: book-browser ( book -- gadget )
|
||||
<frame> over set-delegate
|
||||
|
|
|
|||
|
|
@ -6,19 +6,24 @@ math namespaces vectors ;
|
|||
|
||||
TUPLE: border size ;
|
||||
|
||||
C: border ( child delegate size -- border )
|
||||
C: border ( delegate size -- border )
|
||||
[ set-border-size ] keep
|
||||
[ set-delegate ] keep
|
||||
[ add-gadget ] keep ;
|
||||
[ set-delegate ] keep ;
|
||||
|
||||
: make-border ( child delegate size -- boder )
|
||||
<border> [ add-gadget ] keep ;
|
||||
|
||||
: empty-border ( child -- border )
|
||||
<gadget> @{ 5 5 0 }@ <border> ;
|
||||
<gadget> @{ 0 0 0 }@ make-border ;
|
||||
|
||||
: gap-border ( child -- border )
|
||||
<gadget> @{ 5 5 0 }@ make-border ;
|
||||
|
||||
: line-border ( child -- border )
|
||||
<etched-gadget> @{ 5 5 0 }@ <border> ;
|
||||
<etched-gadget> @{ 5 5 0 }@ make-border ;
|
||||
|
||||
: bevel-border ( child -- border )
|
||||
<bevel-gadget> @{ 5 5 0 }@ <border> ;
|
||||
<bevel-gadget> @{ 5 5 0 }@ make-border ;
|
||||
|
||||
: layout-border-loc ( border -- )
|
||||
dup border-size swap gadget-child set-rect-loc ;
|
||||
|
|
|
|||
|
|
@ -11,12 +11,8 @@ lists math namespaces sdl sequences sequences styles threads ;
|
|||
: button-pressed? ( button -- ? )
|
||||
#! Return true if the mouse was clicked on the button, and
|
||||
#! is currently over the button.
|
||||
dup mouse-over? [
|
||||
1 button-down?
|
||||
[ hand hand-clicked child? ] [ drop f ] if
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
dup mouse-over? 1 button-down? and
|
||||
[ hand hand-clicked child? ] [ drop f ] if ;
|
||||
|
||||
: button-update ( button -- )
|
||||
dup dup mouse-over? rollover set-paint-prop
|
||||
|
|
@ -52,11 +48,12 @@ lists math namespaces sdl sequences sequences styles threads ;
|
|||
TUPLE: button ;
|
||||
|
||||
C: button ( gadget quot -- button )
|
||||
rot bevel-border over set-delegate
|
||||
dup button-theme [ swap button-gestures ] keep ;
|
||||
<bevel-gadget> @{ 5 5 0 }@ <border> over set-delegate
|
||||
dup button-theme [ swap button-gestures ] keep
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
: <roll-button> ( gadget quot -- button )
|
||||
>r dup roll-button-theme dup r> button-gestures ;
|
||||
>r empty-border dup roll-button-theme dup r> button-gestures ;
|
||||
|
||||
: repeat-button-down ( button -- )
|
||||
dup 100 add-timer button-clicked ;
|
||||
|
|
|
|||
|
|
@ -74,7 +74,8 @@ TUPLE: editor line caret ;
|
|||
[[ [ gain-focus ] [ focus-editor ] ]]
|
||||
[[ [ lose-focus ] [ unfocus-editor ] ]]
|
||||
[[ [ button-down 1 ] [ click-editor ] ]]
|
||||
[[ [ "BACKSPACE" ] [ [ backspace ] with-editor ] ]]
|
||||
[[ [ "BACKSPACE" ] [ [ delete-prev ] with-editor ] ]]
|
||||
[[ [ "DELETE" ] [ [ delete-next ] with-editor ] ]]
|
||||
[[ [ "LEFT" ] [ [ left ] with-editor ] ]]
|
||||
[[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
|
||||
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ C: frame ( -- frame )
|
|||
: get-bottom ( frame -- gadget ) 1 2 frame-child ;
|
||||
|
||||
: reduce-grid ( grid -- seq )
|
||||
[ @{ 0 0 0 }@ [ vmax ] reduce ] map ;
|
||||
[ max-dim ] map ;
|
||||
|
||||
: frame-pref-dim ( grid -- dim )
|
||||
reduce-grid @{ 0 0 0 }@ [ v+ ] reduce ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,11 @@ M: array rect-dim drop @{ 0 0 0 }@ ;
|
|||
: >absolute ( rect -- rect )
|
||||
rect-bounds >r origin get v+ r> <rect> ;
|
||||
|
||||
: |v-| ( vec vec -- vec ) v- [ 0 max ] map ;
|
||||
|
||||
: intersect ( rect rect -- rect )
|
||||
[ rect-extent ] 2apply swapd vmin >r vmax dup r>
|
||||
swap v- @{ 0 0 0 }@ vmax <rect> ;
|
||||
swap |v-| <rect> ;
|
||||
|
||||
: intersects? ( rect/point rect -- ? )
|
||||
[ rect-extent ] 2apply swapd vmin >r vmax r> v-
|
||||
|
|
@ -73,3 +75,5 @@ M: gadget children-on ( rect/point gadget -- list )
|
|||
[ nip pick-up ] [ rot 2drop ] if
|
||||
] with-scope
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ;
|
||||
|
|
|
|||
|
|
@ -98,13 +98,16 @@ C: pack ( vector -- pack )
|
|||
|
||||
: <pile> ( -- pack ) @{ 0 1 0 }@ <pack> ;
|
||||
|
||||
: make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
|
||||
|
||||
: <shelf> ( -- pack ) @{ 1 0 0 }@ <pack> ;
|
||||
|
||||
: make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
|
||||
|
||||
M: pack pref-dim ( pack -- dim )
|
||||
[
|
||||
[
|
||||
pref-dims
|
||||
[ @{ 0 0 0 }@ [ vmax ] reduce ] keep
|
||||
pref-dims [ max-dim ] keep
|
||||
[ @{ 0 0 0 }@ [ v+ ] reduce ] keep length 1 - 0 max
|
||||
] keep pack-gap n*v v+
|
||||
] keep pack-vector set-axis ;
|
||||
|
|
|
|||
|
|
@ -106,10 +106,15 @@ SYMBOL: history-index
|
|||
>r line-text get head r> append
|
||||
line-text set ;
|
||||
|
||||
: backspace ( -- )
|
||||
: delete-prev ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
caret get dup 0 = [ drop ] [ 1- 1 line-remove ] if ;
|
||||
|
||||
: delete-next ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
caret get dup line-text get length =
|
||||
[ drop ] [ 1 line-remove ] if ;
|
||||
|
||||
: left ( -- )
|
||||
#! Call this in the line editor scope.
|
||||
caret [ 1- 0 max ] change ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ gadgets-labels generic kernel lists math namespaces sequences ;
|
|||
|
||||
: fit-bounds ( loc dim max -- loc )
|
||||
#! Adjust loc to fit inside max.
|
||||
swap v- @{ 0 0 0 }@ vmax vmin ;
|
||||
swap |v-| vmin ;
|
||||
|
||||
: menu-loc ( menu -- loc )
|
||||
hand rect-loc swap rect-dim world get rect-dim fit-bounds ;
|
||||
|
|
@ -31,7 +31,7 @@ gadgets-labels generic kernel lists math namespaces sequences ;
|
|||
#! Given an association list mapping labels to quotations.
|
||||
#! Prepend a call to hide-menu to each quotation.
|
||||
[ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
|
||||
<pile> 1 over set-pack-fill [ add-gadgets ] keep ;
|
||||
make-pile 1 over set-pack-fill ;
|
||||
|
||||
: menu-theme ( menu -- )
|
||||
<< solid >> interior set-paint-prop ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,8 @@ TUPLE: outliner gadget quot pile expanded? ;
|
|||
: find-outliner [ outliner? ] find-parent ;
|
||||
|
||||
: <expand-button> ( -- gadget )
|
||||
"+" <label> [ find-outliner toggle-outliner ] <roll-button> ;
|
||||
right <polygon-gadget>
|
||||
[ find-outliner toggle-outliner ] <roll-button> ;
|
||||
|
||||
C: outliner ( gadget quot -- gadget )
|
||||
#! The quotation generates child gadgets.
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic hashtables io kernel lists math matrices
|
||||
namespaces sdl sequences strings styles vectors ;
|
||||
USING: alien arrays gadgets-layouts generic hashtables io kernel
|
||||
lists math matrices namespaces sdl sequences strings styles
|
||||
vectors ;
|
||||
|
||||
SYMBOL: clip
|
||||
|
||||
|
|
@ -137,17 +138,15 @@ TUPLE: bevel width ;
|
|||
SYMBOL: bevel-1
|
||||
SYMBOL: bevel-2
|
||||
|
||||
: bevel-up ( gadget -- rgb )
|
||||
dup reverse-video paint-prop bevel-1 bevel-2 ? paint-prop rgb ;
|
||||
|
||||
: bevel-down ( gadget -- rgb )
|
||||
dup reverse-video paint-prop bevel-2 bevel-1 ? paint-prop rgb ;
|
||||
: bevel-color ( gadget ? -- rgb )
|
||||
>r dup reverse-video paint-prop bevel-1 bevel-2
|
||||
r> [ swap ] when ? paint-prop rgb ;
|
||||
|
||||
: draw-bevel ( v1 v2 gadget -- )
|
||||
[ >r x1/x2/y1 r> bevel-up hlineColor ] keep
|
||||
[ >r x1/x2/y2 r> bevel-down hlineColor ] keep
|
||||
[ >r x1/y1/y2 r> bevel-up vlineColor ] keep
|
||||
[ >r x2/y1/y2 r> bevel-down vlineColor ] keep
|
||||
[ >r x1/x2/y1 r> f bevel-color hlineColor ] keep
|
||||
[ >r x1/x2/y2 r> t bevel-color hlineColor ] keep
|
||||
[ >r x1/y1/y2 r> f bevel-color vlineColor ] keep
|
||||
[ >r x2/y1/y2 r> t bevel-color vlineColor ] keep
|
||||
3drop ;
|
||||
|
||||
M: bevel draw-boundary ( gadget boundary -- )
|
||||
|
|
@ -172,8 +171,49 @@ M: gadget draw-gadget* ( gadget -- )
|
|||
: <bevel-gadget> ( -- gadget )
|
||||
<plain-gadget> dup << bevel f 2 >> boundary set-paint-prop ;
|
||||
|
||||
: draw-line ( from to color -- )
|
||||
>r >r >r surface get r> first2 r> first2 r> rgb lineColor ;
|
||||
! Polygon pen
|
||||
TUPLE: polygon points ;
|
||||
|
||||
: draw-fanout ( from tos color -- )
|
||||
-rot [ >r 2dup r> rot draw-line ] each 2drop ;
|
||||
: >short-array ( seq -- short-array )
|
||||
dup length <short-array> over length [
|
||||
[ tuck >r >r swap nth r> r> swap set-short-nth ] 3keep
|
||||
] repeat nip ;
|
||||
|
||||
: polygon-x/y ( polygon -- vx vy n )
|
||||
polygon-points [
|
||||
origin get swap [ v+ ] map-with
|
||||
dup [ first ] map swap [ second ] map
|
||||
[ >short-array ] 2apply
|
||||
] keep length ;
|
||||
|
||||
: (polygon) ( gadget polygon -- surface vx vy n gadget )
|
||||
swap >r surface get swap polygon-x/y r> ;
|
||||
|
||||
M: polygon draw-boundary ( gadget polygon -- )
|
||||
(polygon) fg rgb polygonColor ;
|
||||
|
||||
M: polygon draw-interior ( gadget polygon -- )
|
||||
(polygon) bg rgb filledPolygonColor ;
|
||||
|
||||
: up @{ @{ 4 0 0 }@ @{ 8 8 0 }@ @{ 0 8 0 }@ }@ ;
|
||||
: right @{ @{ 0 0 0 }@ @{ 8 4 0 }@ @{ 0 8 0 }@ }@ ;
|
||||
: down @{ @{ 0 0 0 }@ @{ 8 0 0 }@ @{ 4 8 0 }@ }@ ;
|
||||
: left @{ @{ 0 4 0 }@ @{ 8 0 0 }@ @{ 8 8 0 }@ }@ ;
|
||||
|
||||
: right|
|
||||
@{
|
||||
@{ 0 0 0 }@ @{ 0 8 0 }@ @{ 8 4 0 }@
|
||||
@{ 8 8 0 }@ @{ 8 0 0 }@ @{ 8 4 0 }@
|
||||
}@ ;
|
||||
|
||||
: |left
|
||||
@{
|
||||
@{ 8 0 0 }@ @{ 8 8 0 }@ @{ 0 4 0 }@
|
||||
@{ 0 8 0 }@ @{ 0 0 0 }@ @{ 0 4 0 }@
|
||||
}@ ;
|
||||
|
||||
: <polygon-gadget> ( points -- gadget )
|
||||
dup max-dim >r <polygon> <gadget> r> over set-rect-dim
|
||||
dup rot interior set-paint-prop
|
||||
dup gray background set-paint-prop
|
||||
dup light-gray rollover-bg set-paint-prop ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ TUPLE: pane output active current input continuation scrolls? ;
|
|||
: add-output 2dup set-pane-output add-gadget ;
|
||||
|
||||
: <active-line> ( current input -- line )
|
||||
[ 2array ] [ 1array ] if* <shelf> [ add-gadgets ] keep ;
|
||||
[ 2array ] [ 1array ] if* make-shelf ;
|
||||
|
||||
: init-active-line ( pane -- )
|
||||
dup pane-active unparent
|
||||
|
|
|
|||
|
|
@ -14,8 +14,6 @@ TUPLE: slider vector elevator thumb value max page ;
|
|||
|
||||
: find-slider [ slider? ] find-parent ;
|
||||
|
||||
: thumb-min @{ 12 12 0 }@ ;
|
||||
|
||||
: slider-scale ( slider -- n )
|
||||
#! A scaling factor such that if x is a slider co-ordinate,
|
||||
#! x*n is the screen position of the thumb, and conversely
|
||||
|
|
@ -61,7 +59,7 @@ SYMBOL: slider-changed
|
|||
|
||||
: elevator-theme ( elevator -- )
|
||||
dup << solid f >> interior set-paint-prop
|
||||
@{ 128 128 128 }@ background set-paint-prop ;
|
||||
light-gray background set-paint-prop ;
|
||||
|
||||
: slide-by ( amount gadget -- )
|
||||
#! The gadget can be any child of a slider.
|
||||
|
|
@ -83,32 +81,42 @@ C: elevator ( -- elevator )
|
|||
<plain-gadget> over set-delegate
|
||||
dup elevator-theme dup elevator-actions ;
|
||||
|
||||
: (layout-thumb) ( slider n -- n )
|
||||
over slider-vector n*v swap slider-thumb ;
|
||||
|
||||
: thumb-loc ( slider -- loc )
|
||||
dup slider-value swap slider>screen ;
|
||||
|
||||
: layout-thumb-loc ( slider -- )
|
||||
dup thumb-loc (layout-thumb) set-rect-loc ;
|
||||
|
||||
: thumb-dim ( slider -- h )
|
||||
dup slider-page swap slider>screen ;
|
||||
|
||||
: layout-thumb-dim ( slider -- )
|
||||
dup dup thumb-dim (layout-thumb)
|
||||
>r >r dup rect-dim r> rot slider-vector set-axis r>
|
||||
set-gadget-dim ;
|
||||
|
||||
: layout-thumb ( slider -- )
|
||||
dup thumb-loc over slider-vector n*v
|
||||
over slider-thumb set-rect-loc
|
||||
dup thumb-dim over slider-vector n*v thumb-min vmax
|
||||
swap slider-thumb set-gadget-dim ;
|
||||
dup layout-thumb-loc layout-thumb-dim ;
|
||||
|
||||
M: elevator layout* ( elevator -- )
|
||||
find-slider layout-thumb ;
|
||||
|
||||
M: elevator pref-dim drop thumb-min ;
|
||||
|
||||
: slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
|
||||
|
||||
: <up-button>
|
||||
<gadget> [ -1 swap slide-by-line ] <repeat-button> ;
|
||||
: slider-vertical? slider-vector @{ 0 1 0 }@ = ;
|
||||
|
||||
: <up-button> ( slider -- button )
|
||||
slider-vertical? up left ? <polygon-gadget>
|
||||
[ -1 swap slide-by-line ] <repeat-button> ;
|
||||
|
||||
: add-up @{ 1 1 1 }@ over slider-vector v- first2 set-frame-child ;
|
||||
|
||||
: <down-button>
|
||||
<gadget> [ 1 swap slide-by-line ] <repeat-button> ;
|
||||
: <down-button> ( slider -- button )
|
||||
slider-vertical? down right ? <polygon-gadget>
|
||||
[ 1 swap slide-by-line ] <repeat-button> ;
|
||||
|
||||
: add-down @{ 1 1 1 }@ over slider-vector v+ first2 set-frame-child ;
|
||||
|
||||
|
|
@ -123,8 +131,8 @@ C: slider ( vector -- slider )
|
|||
0 over set-slider-page
|
||||
0 over set-slider-max
|
||||
<elevator> over add-elevator
|
||||
<up-button> over add-up
|
||||
<down-button> over add-down
|
||||
dup <up-button> over add-up
|
||||
dup <down-button> over add-down
|
||||
<thumb> over add-thumb ;
|
||||
|
||||
: <x-slider> ( -- slider ) @{ 1 0 0 }@ <slider> ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue