+ bugs to fix soon\r
\r
-<erg> if write returns -1 and errno == EINTR then it's not a real error, you can try again\r
-\r
<magnus--> http://developer.apple.com/technotes/tn2004/tn2123.html#SECLIMITATIONS\r
<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4742.html\r
<magnus--> not *too* long\r
styles ;
: ttf-name ( font style -- name )
- cons [
+ cons {{
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Serif" italic ]] "VeraIt" ]]
- ] assoc ;
+ }} hash ;
: ttf-path ( name -- string )
[ resource-path % "/fonts/" % % ".ttf" % ] make-string ;
: ttf-init ( -- )
TTF_Init
- open-fonts [ [ cdr expired? not ] hash-subset ] change ;
+ global [
+ open-fonts [ [ cdr expired? not ] hash-subset ] change
+ ] bind ;
: gadget-font ( gadget -- font )
[ font paint-prop ] keep
USING: generic hashtables kernel lists math matrices namespaces
sequences ;
-: remove-gadget ( gadget box -- )
+: remove-gadget ( gadget parent -- )
[ 2dup gadget-children remq swap set-gadget-children ] keep
relayout
f swap set-gadget-parent ;
-: (add-gadget) ( gadget box -- )
- #! This is inefficient.
- [ gadget-children swap add ] keep
- set-gadget-children ;
-
: unparent ( gadget -- )
[
dup gadget-parent dup
[ remove-gadget ] [ 2drop ] ifte
] when* ;
-: add-gadget ( gadget box -- )
- #! Add a gadget to a box.
+: (add-gadget) ( gadget box -- )
+ #! This is inefficient.
over unparent
dup pick set-gadget-parent
- tuck (add-gadget)
- relayout ;
+ [ gadget-children swap add ] keep set-gadget-children ;
+
+: add-gadget ( gadget parent -- )
+ #! Add a gadget to a parent gadget.
+ [ (add-gadget) ] keep relayout ;
-: (parent-list) ( gadget -- )
- [ dup gadget-parent (parent-list) , ] when* ;
+: (parents) ( gadget -- )
+ [ dup gadget-parent (parents) , ] when* ;
-: parent-list ( gadget -- list )
+: parents ( gadget -- list )
#! A list of all parents of the gadget, including the
#! gadget itself.
- [ (parent-list) ] make-list ;
+ [ (parents) ] make-list ;
: (each-parent) ( list quot -- ? )
over [
: each-parent ( gadget quot -- ? )
#! Keep executing the quotation on higher and higher
#! parents until it returns f.
- >r parent-list r> (each-parent) ; inline
+ >r parents r> (each-parent) ; inline
: screen-pos ( gadget -- point )
#! The position of the gadget on the screen.
TUPLE: incremental cursor ;
-M: incremental pref-dim incremental-cursor ;
-
C: incremental ( pack -- incremental )
[ set-delegate ] keep
{ 0 0 0 } over set-incremental-cursor ;
+M: incremental pref-dim incremental-cursor ;
+
+M: incremental layout* drop ;
+
: next-cursor ( gadget incremental -- cursor )
[
swap shape-dim swap incremental-cursor
dup incremental-cursor dup rot pack-vector v* v-
swap set-shape-loc ;
+: prefer-incremental ( gadget -- )
+ dup pref-dim swap set-shape-dim ;
+
: add-incremental ( gadget incremental -- )
- 2dup add-gadget
- >r dup dup pref-dim swap set-shape-dim r>
- f over set-gadget-relayout?
- 2dup incremental-loc update-cursor ;
+ 2dup (add-gadget)
+ over prefer-incremental
+ 2dup incremental-loc
+ tuck update-cursor
+ prefer-incremental ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel math namespaces styles ;
+USING: generic io kernel listener math namespaces styles threads ;
global [
<world> world set
{{
-
[[ background [ 255 255 255 ] ]]
- [[ rollover-bg [ 216 216 216 ] ]]
+ [[ rollover-bg [ 255 255 204 ] ]]
[[ foreground [ 0 0 0 ] ]]
[[ reverse-video f ]]
[[ font "Sans Serif" ]]
<plain-gadget> add-layer
- <console> dup
- "Stack display goes here" <label> <y-splitter>
+ <pane> dup
+
+ <scroller> "Stack display goes here" <label> <y-splitter>
3/4 over set-splitter-split add-layer
+ dup
+ [ [ clear print-banner listener ] in-thread ] with-stream
+
request-focus
] bind
C: pane ( -- pane )
<line-pile> over set-delegate
- <line-pile> ( <incremental> ) over add-output
+ <line-pile> <incremental> over add-output
<line-shelf> over set-pane-current
"" <editor> over set-pane-input
dup init-active-line
[ <presentation> ] keep pane-current add-gadget ;
: pane-terpri ( pane -- )
- dup pane-current over pane-output ( add-incremental ) add-gadget
+ dup pane-current over pane-output add-incremental
<line-shelf> over set-pane-current init-active-line ;
: pane-write ( style pane list -- )
M: pane stream-close ( stream -- ) drop ;
: <console> ( -- pane )
- <pane> dup
- [ [ clear print-banner listener ] in-thread ] with-stream
- <scroller> ;
+ <pane> <scroller> ;