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

splitter control in the UI works, improving panes, various UI cleanups

cvs
Slava Pestov 2005-06-26 00:39:53 +00:00
parent 3c5ebd288a
commit 49769678d1
14 changed files with 93 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
library/collections/lists.factor
View File

@ -64,7 +64,7 @@ M: general-list contains? ( obj list -- ? )
2dup contains? [ nip ] [ cons ] ifte ;
M: general-list reverse ( list -- list )
[ ] swap [ swons ] each ;
[ ] [ swons ] reduce ;
M: f map ( list quot -- list ) drop ;

6
library/collections/sequences.factor
View File

@ -32,6 +32,9 @@ G: each ( seq quot -- | quot: elt -- )
: each-with ( obj seq quot -- | quot: obj elt -- )
swap [ with ] each 2drop ; inline
: reduce ( list identity quot -- value | quot: x y -- z )
swapd each ; inline
G: tree-each ( obj quot -- | quot: elt -- )
[ over ] [ type ] ; inline
@ -44,6 +47,9 @@ G: map ( seq quot -- seq | quot: elt -- elt )
: map-with ( obj list quot -- list | quot: obj elt -- elt )
swap [ with rot ] map 2nip ; inline
: accumulate ( list identity quot -- values | quot: x y -- z )
rot [ pick >r swap call r> ] map-with nip ; inline
G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
[ over ] [ type ] ; inline

7
library/math/matrices.factor
View File

@ -17,8 +17,11 @@ vectors ;
: vmin ( v v -- v ) [ min ] 2map ;
: vneg ( v -- v ) [ neg ] map ;
: sum ( v -- n ) 0 swap [ + ] each ;
: product 1 swap [ * ] each ;
: sum ( v -- n ) 0 [ + ] reduce ;
: product 1 [ * ] reduce ;
: set-axis ( x y axis -- v )
2dup v* >r >r drop dup r> v* v- r> v+ ;
! Later, this will fixed when 2each works properly
! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;

7
library/sdl/sdl-utils.factor
View File

@ -43,13 +43,6 @@ SYMBOL: surface
[ set-rect-y ] keep
[ set-rect-x ] keep ;
: black [ 0 0 0 ] ;
: gray [ 128 128 128 ] ;
: white [ 255 255 255 ] ;
: red [ 255 0 0 ] ;
: green [ 0 255 0 ] ;
: blue [ 0 0 255 ] ;
: with-pixels ( quot -- )
width get [
height get [

2
library/syntax/parse-numbers.factor
View File

@ -20,7 +20,7 @@ M: object digit> not-a-number ;
dup empty? [
not-a-number
] [
0 swap [ digit> pick digit+ ] each nip
0 [ digit> pick digit+ ] reduce nip
] ifte ;
: base> ( str base -- num )

7
library/test/sequences.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: lists sequences test vectors ;
USING: lists math sequences test vectors ;
[ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
[ 3 ] [ 1 4 <range> length ] unit-test
@ -14,3 +14,8 @@ USING: lists sequences test vectors ;
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
[ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test
[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
[ [ 1 1 2 6 24 120 720 ] ]
[ [ 1 2 3 4 5 6 7 ] 1 [ * ] accumilate ] unit-test

8
library/ui/colors.factor Normal file
View File

@ -0,0 +1,8 @@
IN: gadgets
: black [ 0 0 0 ] ;
: gray [ 128 128 128 ] ;
: white [ 255 255 255 ] ;
: red [ 255 0 0 ] ;
: green [ 0 255 0 ] ;
: blue [ 0 0 255 ] ;

8
library/ui/gadgets.factor
View File

@ -90,11 +90,3 @@ M: gadget layout*
GENERIC: user-input* ( ch gadget -- ? )
M: gadget user-input* 2drop t ;
GENERIC: orientation ( gadget -- vector )
: orient* ( x y axis -- v )
2dup v* >r >r drop dup r> v* v- r> v+ ;
: orient ( x y gadget -- vec )
orientation orient* ;

6
library/ui/init-world.factor
View File

@ -16,4 +16,10 @@ global [
}} world get set-gadget-paint
1024 768 world get resize-gadget
<plain-gadget> world get add-gadget
<console> "Stack display goes here" <label> <y-splitter>
3/4 over set-splitter-split
world get add-gadget
] bind

37
library/ui/panes.factor
View File

@ -7,15 +7,20 @@ sequences io strings threads ;
! A pane is an area that can display text.
! output: pile
! current: label
! current: shelf
! input: editor
TUPLE: pane output current input continuation ;
TUPLE: pane output active current input continuation ;
: add-output 2dup set-pane-output add-gadget ;
: add-input 2dup set-pane-input add-gadget ;
: <active-line> ( current input -- line )
<line-shelf> [ tuck add-gadget add-gadget ] keep ;
: <active-line> ( input current -- line )
<line-shelf> [ add-gadget ] keep [ add-gadget ] keep ;
: init-active-line ( pane -- )
dup pane-active [ unparent ] when*
[ dup pane-input swap pane-current <active-line> ] keep
2dup set-pane-active add-gadget ;
: pane-paint ( pane -- )
[[ "Monospaced" 12 ]] font set-paint-prop ;
@ -43,22 +48,18 @@ TUPLE: pane output current input continuation ;
C: pane ( -- pane )
<line-pile> over set-delegate
<line-pile> over add-output
"" <label> dup pick set-pane-current >r
"" <editor> dup pick set-pane-input r>
<active-line> over add-gadget
"" <label> over set-pane-current
"" <editor> over set-pane-input
dup init-active-line
dup pane-paint
dup pane-actions ;
: add-line ( text pane -- )
>r <label> r> pane-output add-gadget ;
: pane-write-1 ( text pane -- )
pane-current dup label-text rot append over set-label-text
relayout ;
>r <label> r> pane-current add-gadget ;
: pane-terpri ( pane -- )
dup pane-current dup label-text rot add-line
"" over set-label-text relayout ;
dup pane-current over pane-output add-gadget
<line-shelf> over set-pane-current init-active-line ;
: pane-write ( pane list -- )
2dup car swap pane-write-1
@ -81,12 +82,12 @@ M: pane stream-write-attr ( string style stream -- )
M: pane stream-close ( stream -- ) drop ;
: <console> ( -- pane )
<pane> dup [
[ clear print-banner listener ] in-thread
] with-stream ;
<pane> dup
[ [ clear print-banner listener ] in-thread ] with-stream
<scroller> ;
: console ( -- )
#! Open an UI console window.
<console> <scroller> "Listener" <tile> world get [
<console> "Listener" <tile> world get [
shape-size rect> 3/4 * >rect rot resize-gadget
] 2keep add-gadget ;

2
library/ui/scrolling.factor
View File

@ -78,7 +78,7 @@ TUPLE: slider viewport thumb vector ;
: <thumb> ( -- thumb )
<plain-gadget>
dup t reverse-video set-paint-prop
dup gray background set-paint-prop
dup thumb-actions ;
: add-thumb ( thumb slider -- )

52
library/ui/splitters.factor
View File

@ -1,21 +1,33 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists matrices namespaces sequences ;
USING: generic kernel lists math matrices namespaces sequences ;
TUPLE: divider splitter ;
C: divider ( -- divider )
<plain-gadget> over set-delegate
dup t reverse-video set-paint-prop ;
: divider-size { 8 8 0 } ;
M: divider pref-size drop divider-size 3unseq drop ;
TUPLE: splitter vector split ;
M: splitter orientation splitter-vector ;
: hand>split ( splitter -- n )
hand relative hand hand-click-rel v- divider-size 1/2 v*n v+ ;
: divider-motion ( splitter -- )
dup hand>split
over shape-dim { 1 1 1 } vmax v/ over splitter-vector v.
0 max 1 min over set-splitter-split relayout ;
: divider-actions ( thumb -- )
dup [ drop ] [ button-down 1 ] set-action
dup [ drop ] [ button-up 1 ] set-action
[ gadget-parent divider-motion ] [ drag 1 ] set-action ;
C: divider ( -- divider )
<plain-gadget> over set-delegate
dup t reverse-video set-paint-prop
dup divider-actions ;
C: splitter ( first second vector -- splitter )
<empty-gadget> over set-delegate
@ -26,16 +38,16 @@ C: splitter ( first second vector -- splitter )
[ add-gadget ] keep
1/2 over set-splitter-split ;
: <x-splitter> { 1 0 0 } <splitter> ;
: <x-splitter> { 0 1 0 } <splitter> ;
: <y-splitter> { 0 1 0 } <splitter> ;
: <y-splitter> { 1 0 0 } <splitter> ;
M: splitter pref-size
[
gadget-children [ pref-dim ] map
dup { 0 0 0 } swap [ vmax ] each
swap { 0 0 0 } swap [ v+ ] each
] keep orient 3unseq drop ;
dup { 0 0 0 } [ vmax ] reduce
swap { 0 0 0 } [ v+ ] reduce
] keep splitter-vector set-axis 3unseq drop ;
: splitter-part ( splitter -- vec )
dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
@ -47,10 +59,22 @@ M: splitter pref-size
dup shape-dim swap splitter-part v- ,
] make-list ;
: packed-locs ( axis sizes gadget -- )
>r
{ 0 0 0 } [ v+ ] accumulate
[ { 0 0 0 } swap rot set-axis ] map-with
r> gadget-children zip [ uncons set-gadget-loc ] each ;
: packed-dims ( axis sizes gadget -- dims )
[
shape-dim swap [ >r 2dup r> rot set-axis ] map 2nip
] keep gadget-children zip [ uncons set-gadget-dim ] each ;
: layout-divider ( assoc -- )
[ uncons set-gadget-dim ] each ;
: packed-layout ( axis sizes gadgets -- )
3dup packed-locs packed-dims ;
M: splitter layout* ( splitter -- )
[
dup splitter-layout [ nip ( { 0 0 0 } rot orient ) ] map-with
] keep gadget-children zip layout-divider ;
dup splitter-vector over splitter-layout rot packed-layout ;

2
library/ui/tool-menus.factor
View File

@ -15,4 +15,4 @@ SYMBOL: root-menu
[[ "Exit" [ f world get set-world-running? ] ]]
] root-menu set
world get [ drop show-root-menu ] [ button-down 1 ] set-action
! world get [ drop show-root-menu ] [ button-down 1 ] set-action

5
library/ui/world.factor
View File

@ -11,11 +11,8 @@ threads sequences ;
! open at any one time.
TUPLE: world running? hand menu ;
: <world-box> ( -- box )
<plain-gadget> ;
C: world ( -- world )
<world-box> over set-delegate
f <stack> over set-delegate
t over set-world-running?
dup <hand> over set-world-hand ;