#! xbigforth
\ graphical widget editor 14sep97py
[defined] VFXFORTH [IF]
include vfx-minos/fileop.fs
[ELSE]
[defined] fileop 0= [IF] include fileop.fb [THEN]
[THEN]
also minos [defined] float-action 0= [IF]
previous include minos-float.fs
[ELSE]
previous
[THEN]
[defined] x11 [IF] \needs xconst | import xconst
[THEN]
Module theseus
fileop also memory also minos also editor also forth also
include theseus-classes.fs
: $@? ( var -- flag ) dup @ IF $@ nip 0<> ELSE @ THEN ;
: .class" ( object -- ) >class" type ;
\ ' .class" IS .class
\ icons
ficon: test-icon icons/computer"
ficon: on-icon icons/mini-exclam"
ficon: off-icon icons/mini-cross"
ficon: minos-icon icons/minos"
ficon: minos-win icons/minos1+"
[defined] alias [IF]
' dir-icon Alias res-icon
' diro-icon Alias resopen-icon
[ELSE]
synonym res-icon dir-icon
synonym resopen-icon diro-icon
[THEN]
\ tools
: >child ( o -- o' )
combined with childs self endwith ;
: >child2 ( o -- o' )
combined with childs widgets self endwith ;
Variable comp#
: anonymous-component ( -- addr u ) base push hex
comp# @ 0 <<# 3 0 ?DO # LOOP #s s" comp" holds #> #>>
1 comp# +! ;
: new-code ( addr u content -- o )
codeedit new
codeedit with c/l cols ! add-lines
0 0 at ^
endwith ;
\ link list
links implements
: init ( linked linker -- ) bind linker bind linked ;
: find-linked ( linker -- linked )
dup linker self = IF drop linked self EXIT THEN
next self IF next goto find-linked ELSE drop 0 THEN ;
: find-linker ( linked -- linker )
dup linked self = IF drop linker self EXIT THEN
next self IF next goto find-linker ELSE drop 0 THEN ;
: update-linked ( new-linked old-linked -- )
dup linked self = IF drop bind linked
linked self linker callback bind called EXIT THEN
next self IF next goto update-linked ELSE 2drop THEN ;
: update-linker ( new-linker old-linker -- )
dup linker self = IF drop bind linker
linked self linker callback bind called EXIT THEN
next self IF next goto update-linker ELSE 2drop THEN ;
: dump ( -- )
cr linked self . linker self .
next self IF next goto dump THEN ;
class;
links ptr first-link
: find-linked
first-link self IF first-link find-linked
ELSE drop 0 THEN ;
: find-linker
first-link self IF first-link find-linker
ELSE drop 0 THEN ;
: update-linked
first-link self IF first-link update-linked
ELSE 2drop THEN ;
: update-linker
first-link self IF first-link update-linker
ELSE 2drop THEN ;
: new-link ( linked linker -- )
links new links with
first-link self bind next
^
endwith bind first-link ;
[defined] DoNotSin [IF] DoNotSin [THEN]
\ name hints for boxes and displays
hint-name ptr names
hint-name implements
: find-name ( o -- o / 0 )
dup hint self = IF drop self EXIT THEN
next self 0= IF drop 0 EXIT THEN
next self @ 0= IF ." broken name object!" cr drop 0 EXIT THEN
next goto find-name ;
: update-hint ( newo oldo -- )
dup hint self = IF drop bind hint EXIT THEN
next self 0= IF 2drop EXIT THEN
next goto update-hint ;
: update-name ( addr u -- )
name $! ;
: init ( addr u o -- )
bind hint name $! names self bind next ;
class;
s" " 0 hint-name new bind names
\ box classifying
Create &boxes
& vbox @ A, & vtbox @ A, & vrbox @ A, & vrtbox @ A,
& vabox @ A, & vatbox @ A, & varbox @ A, & vartbox @ A,
& hbox @ A, & htbox @ A, & hrbox @ A, & hrtbox @ A,
& habox @ A, & hatbox @ A, & harbox @ A, & hartbox @ A,
0 , 0 , 0 , & vtab @ A,
& vresize @ A, & vasbox @ A, 0 , & vatab @ A,
0 , 0 , 0 , & htab @ A,
& hresize @ A, & hasbox @ A, 0 , & hatab @ A,
: ?hbox ( object -- flag )
@ 0 $20 0 DO I 8 and IF over &boxes Ith = or THEN
LOOP nip ;
: ?abox ( object -- flag )
@ 0 $20 0 DO I 4 and IF over &boxes Ith = or THEN
LOOP nip ;
: ?rbox ( object -- flag )
@ 0 $10 0 DO I 2 and IF over &boxes Ith = or THEN
LOOP nip ;
: ?tbox ( object -- flag )
@ 0 $10 0 DO I 1 and IF over &boxes Ith = or THEN
LOOP nip ;
: ?table ( object -- flag )
@ 0 $20 $13 DO over &boxes Ith = or
4 +LOOP nip ;
: (makebox ( n -- )
cells &boxes + @ new, ;
Variable indent
#40 Value delay-to
\ class descriptor
descriptor implements
: DELAY ( -- )
^ screen cleanup screen sync
r> ^ delay-to after screen schedule ;
: edit-field ;
: null ;
: make ;
: dump ;
: post-dump ( -- ) ;
: assign ;
: get ;
class;
forward bind-cur
forward dump-names
forward dump-box
forward addinstead
forward dispose-box
widget ptr edit-string
widget ptr code-string
widget ptr code2-string
widget ptr code-label
widget ptr code2-label
widget ptr name-string
infotextfield class infocodefield
codeedit ptr code-lines
cell var ^content
how:
: init ( act xxx addr2 u2 -- )
rot ^content !
text-label new dup bind info
0 1 *fill 2dup glue new
2 vabox new
^content @ HLock
get ^content @ new-code dup bind code-lines
dup F bind code-string
^content @ HUnLock
1 habox new -2 borderbox
0 1 *fill 2dup glue new
3 super super super init ;
: assign ( addr u -- ) ^content @ $! ;
: get ( -- addr u ) ^content @ $@ ;
class;
: minos-design ( o -- o )
hxrtsizer new 2 hasbox new
vxrtsizer new 2 vasbox new
0 1 *filll 2dup rule new dup rule with $D assign endwith
2 habox new
1 vabox new ;
: link-resource ( .. o -- o' )
resource:dialog with
link-designer
^ var-box self methods-box self endwith
>r rot r> swap 4 vabox new ;
: minos:dialog ( -- o )
cross new 1 vabox new panel 1 designerbox new
dup >r minos-design
dup resource:dialog new
r@ swap link-resource
r> designerbox with <box> endwith ;
: minos:menu-window ( -- o )
cross new 1 hbox new vfixbox
cross new 1 vabox new panel 2 vbox new 1 designerbox new
dup >r minos-design
dup resource:menu-window new
r@ swap link-resource
r> designerbox with <box> endwith ;
theseus
designer ptr cur
forward auto-save-minos
forward do-auto-save
: schedule-auto-save ( -- )
['] do-auto-save cur self #120000 after
cur dpy schedule ;
: do-auto-save
cur self >r ^ bind cur
cur save-state @
IF auto-save-minos schedule-auto-save THEN
r> bind cur ;
Variable loading loading off
: changed ( -- ) loading @ ?EXIT
cur save-state @ cur save-state on
0= IF
cur with s" *" title+! endwith
schedule-auto-save THEN ;
: bind-cur ^ bind cur ;
: box-name ( o -- ) >r s" " r> hint-name new bind names ;
: (addbox ( object n -- o )
cur +boxmode @ 0<> 8 and
cur +activate @ 0<> 4 and or
cur +tabular @ IF
$13 or
ELSE
cur +radio @ 0<> 2 and or
cur +tabbing @ 0<> 1 and or
THEN
(makebox dup box-name \ )
cur +hfixbox @ IF hfixbox THEN
cur +vfixbox @ IF vfixbox THEN
cur +flipbox @ IF flipbox THEN
\ cur +rzbox @ IF rzbox THEN
cur +hskip @ IF cur +hskip @ hskips THEN
cur +vskip @ IF cur +vskip @ vskips THEN
cur +borderw @ IF cur +borderw @ borderbox THEN
cur +noborder @ IF cur +noborder @ noborderbox THEN
changed ;
Variable set-var
Variable nvar
forward >current-name
forward addcardfile
\ editor variant
Create newline 1 c, #lf c,
: $+line ( addr u string -- ) >r
r@ $@len IF
newline count r@ dup $@len $ins THEN
r> dup $@len $ins ;
codeedit implements
: init ( content -- )
(straction super init ^content ! ;
: xinc 0 1 ;
: yinc 0 1 ;
: save-contents ( addr u -- )
^content @ $+line ;
: backup s" " ^content @ $!
['] save-contents dump ;
: add-lines ( addr u -- )
dup 0= IF add EXIT THEN
BEGIN
2dup #lf scan dup >r 2swap r> -
dup 1+ cols @ max cols ! add dup WHILE
1 safe/string REPEAT
2drop
thisline @ 0= ?EXIT thisline @
BEGIN dup @ cell+ @ dup WHILE nip REPEAT drop thisline !
1 line#! 0 pos! ;
: dispose backup :: dispose ;
: defocus backup :: defocus ;
class;
\ descriptors
include theseus-desc.fs
\ designer
AVariable do-it
: do-click do-it @ perform ;
: do-key do-it @ cell+ perform ;
: <rebox> ( -- ) cur self 0= ?EXIT cur box self 0= ?EXIT
cur box self names find-name ?dup 0= IF
s" " cur box self hint-name new dup bind names
THEN
cur bind cur-box-name
cur cur-box-name name $@ cur cur-box-edit assign ;
: <redpy> ( -- ) cur self 0= ?EXIT cur widget self 0= ?EXIT
cur widget dpy self all-descs find-object
dup cur bind cur-dpy
IF cur cur-dpy with descriptors name $@ endwith
cur cur-dpy-edit assign
ELSE
s" " cur cur-dpy-edit assign
THEN ;
designerbox implements
: hide ( -- )
0 cur bind box 0 cur bind widget super hide ;
: draw-decor ( -- )
cur box self
IF
$FF 0 0 rgb> $BF 0 0 rgb>
2 cur box xywh 2swap -2 -2 p+ 2swap 4 4 p+
cur box drawshadow
THEN
cur widget self
IF
0 $7F $FF rgb> 0 $5F $BF rgb>
1 cur widget xywh 2swap -1 -1 p+ 2swap 2 2 p+
cur widget drawshadow
THEN
cur resources default $@ dup
IF >r >r shadow swap xS 2/
r> r> all-descs find-name ?dup
IF descriptors with item with xywh
xN 1+ 2/ negate xywh- drawshadow endwith endwith
ELSE drop 2drop THEN
ELSE 2drop THEN ;
: draw ( -- ) super draw draw-decor ;
: <box> ( -- )
& resource:menu-window @ cur resources class? IF
childs with childs self endwith cur bind menubox
childs with childs widgets self endwith
ELSE
childs self
THEN
dup cur bind topbox cur bind box ;
: clicked ( x y b n -- ) <box> do-click <rebox> <redpy>
['] draw-decor ^ #50 after screen schedule ;
: keyed ( key sh -- ) <box> do-key
['] draw-decor ^ #50 after screen schedule ;
: moved ( x y -- )
2drop do-it @ 2 cells + @ dpy set-cursor ;
: init ( o1 .. on n -- )
super init ^ panel drop ;
class;
8 colors designerbox defocuscol !
8 colors designerbox focuscol !
\ resource bar
resource:dialog ptr dialog-stack
resource:dialog implements
: ?menu-call ( flag -- )
IF menu-call toggle THEN ;
: edit-toggle combined +flip changed ;
: edit-box { addr u taddr tu content icon } ( --> box edit )
s" " content $!
addr u text-label new
content codeedit new dup >r
dup codeedit with s" " add-lines 0 0 at $40 cols !
edifile off endwith
1 vabox new -2 borderbox
0 1 *fill 2dup glue new
2 habox new 2 vabox new
dup >r flipbox
false ['] edit-toggle combined ' -flip toggle new
taddr tu TT-string
icon flipicon new r> r> ;
: send-key ( c -- ) 0 callwind keyed ;
: send-keys ( addr u -- )
bounds ?DO I c@ send-key LOOP ;
: prev-resource-link ( -- addr )
cur link resources
BEGIN dup @ WHILE
dup @ ^ <> WHILE
@ >o link next-resource o> REPEAT
ELSE true abort" not found" THEN ;
: cut ( -- )
parent self parent parent with combined remove endwith
prev-resource-link next-resource self swap !
dialog-stack self bind next-resource
^ F bind dialog-stack ;
: paste-before ( -- ) dialog-stack self 0= ?EXIT
dialog-stack parent self parent self
parent parent with combined add resized endwith
dialog-stack self
dialog-stack next-resource self F bind dialog-stack
next-resource self over >o bind next-resource o>
bind next-resource ;
: paste-after ( -- ) dialog-stack self 0= ?EXIT
dialog-stack parent self parent widgets self
parent parent with combined add resized endwith
dialog-stack self
dialog-stack next-resource self F bind dialog-stack
dup prev-resource-link !
self swap >o bind next-resource o> ;
: dispose ( -- ) \ uncomplete
default HandleOff
topbox self dispose-box
next-resource self prev-resource-link !
super dispose ;
: init ( box -- )
s" " default $!
cur callwind self bind callwind
cur resources self bind next-resource
^ cur bind resources
true combined ' +flip combined ' -flip toggle new
TT" Dialog Editor"
res-icon resopen-icon toggleicon new
s" Vars:" s" Edit Variables"
var-content icon" icons/vars" edit-box
bind var-edit bind var-box
s" Methods:" s" Edit Methods"
methods-content icon" icons/code" edit-box
bind methods-edit bind methods-box
TV[ ^ shown changed ]T[ changed ]TV shown on
TT" Show Dialog"
off-icon on-icon toggleicon new
dup bind show-state
^ S[ ^ S[ cut ]S s" Cut Dialog" menu-entry new
dialog-stack self
IF ^ S[ paste-before ]S s" Paste Before" menu-entry new
^ S[ paste-after ]S s" Paste After" menu-entry new
THEN
hline
^ S[ name-string self IF name-string get default $! THEN
cur resources topbox parent draw ]S
s" Set Default" menu-entry new
^ S[ S" " default $! cur pane draw ]S
s" No Default" menu-entry new
hline
^ S[ s" ed " send-keys
class-file $@?
IF class-file $@ send-keys
ELSE name-field get send-keys s" -classes.fs" send-keys THEN
#cr send-key
]S s" Edit decl" menu-entry new 1 habox new hfixbox
class-file @
IF class-file $@ ELSE s" " THEN
^ ST[ CF-field get class-file $! ]ST
( s" CF:" info) textfield new dup bind CF-field 2 habox new
^ S[ s" ed " send-keys
implementation-file $@?
IF implementation-file $@ send-keys
ELSE name-field get send-keys s" .fs" send-keys THEN
#cr send-key
]S s" Edit impl" menu-entry new 1 habox new hfixbox
implementation-file @
IF implementation-file $@ ELSE s" " THEN
^ ST[ IF-field get implementation-file $! ]ST
( s" SF:" info) textfield new dup bind IF-field 2 habox new
dialog-stack self IF 9 ELSE 7 THEN vabox new
2 borderbox dup >r [defined] x11 [IF] dpy get-win swap [THEN]
menu-icon with menu-frame popup endwith ?menu-call
r> with dispose endwith
]S TT" Dialog Menu"
icon" icons/menu" icon-but new dup bind menu-icon
5 hatbox new hfixbox
t" No Title" 0 ST[ ]ST s" Title:" infotextfield new
dup bind title-field
anonymous-component 0 ST[ ]ST s" Name:" infotextfield new
dup bind name-field
2 habox new 2 borderbox
2 super init self ( rzbox) drop ;
: .default ( -- )
default $@ dup 0= IF 2drop ." 0" EXIT THEN
type ." self" ;
: dump-declaration ( -- )
next-resource self
IF next-resource dump-declaration THEN
name-field get nip 0<> IF
class-file $@?
IF cr ." include " class-file $@ type THEN
cr base-class type ." class " name-field get type
cr ." public:"
nvar off set-var on 2 indent !
dump-names' var-edit backup
cr ." ( [varstart] ) " var-content $@ type
." ( [varend] )"
nvar off set-var off 6 indent !
cr ." how:" cr
.' : params DF[ ' .default
.' ]DF X" ' title-field get type
.' " ;' cr
." class;" cr
THEN ;
: dump-implementation ( -- )
name-field get nip 0<> IF
implementation-file $@?
IF cr ." include " implementation-file $@ type THEN
cr name-field get type ." implements" methods-edit backup
cr ." ( [methodstart] ) " methods-content $@ type
." ( [methodend] )"
cr ." : widget ( [dumpstart] )"
dump-contents
cr .' ( [dumpend] ) ;'
cr ." class;" cr
THEN
next-resource self 0= ?EXIT
next-resource goto dump-implementation ;
: dump-script ( n -- n+1 )
name-field get nip 0<> IF
shown @ IF
cr 2 spaces name-field get type
.' open-app' 1+
THEN
THEN
next-resource self 0= ?EXIT
next-resource goto dump-script ;
: script? ( flag -- flag' )
shown @ or
next-resource self 0= ?EXIT
next-resource goto script? ;
: find-name ( addr u -- o/0 )
2dup name-field get compare 0=
IF 2drop ^ EXIT THEN
next-resource self 0= IF 2drop 0 EXIT THEN
next-resource goto find-name ;
\ object-specific parts
: base-class ( -- addr u )
s" component" ;
: dump-contents ( -- )
topbox self dump-box ;
: dump-names' ( -- )
topbox self dump-names ;
: link-designer ( o -- )
>child bind topbox ;
: add-box ( o -- )
topbox self dup cur bind box cur bind topbox addinstead ;
: >cur ( -- )
cur topbox self bind topbox topbox show ;
class;
resource:menu-window implements
: base-class s" menu-component" ;
: .default ( -- )
default $@ dup 0= IF 2drop ." 0" EXIT THEN
type ." self" ;
resource:dialog :: dump-declaration ( -- )
resource:dialog :: dump-implementation ( -- )
resource:dialog :: dump-script ( n -- n+1 )
: dump-contents ( -- )
topbox childs self dump-box
topbox childs widgets self dump-box ;
resource:dialog :: link-designer
resource:dialog :: dump-names'
resource:dialog :: >cur
: add-box ( o1 o2 -- ) 2 vbox new resource:dialog :: add-box ;
resource:dialog :: init
resource:dialog :: script?
resource:dialog :: find-name
class;
\ boxes
Patch +object
Patch cur-dpy
forward addbox
Variable reenter
: ?emptybox
cur box self 0= IF cur topbox self cur bind box THEN
cur box childs self @ & cross @ =
IF cur box childs self dup cur box remove
dup cur widget self = IF 0 cur bind widget THEN
widget with dispose endwith
THEN changed ;
\ check for cardfile structure: vbox{harbox, hbox}
: ?cardfile ( -- )
cur box self cur topbox self <> IF
cur box parent self cur topbox self <> IF
& harbox @ cur box class? IF
& vbox @ cur box parent class? IF
& hbox @ cur box widgets class? ?EXIT
THEN
THEN
THEN
THEN
cross new 1 $E (makebox dup box-name vfixbox dup >r
cross new 1 $C (makebox dup box-name
2 borderbox :notshadow noborderbox
2 $4 (makebox dup box-name +object r> cur bind box ;
: addfirst ?emptybox
cur box childs self
cur box with add resized endwith ;
: addlast ?emptybox
'nil cur box with add resized endwith ;
: addafter
cur widget self 0= IF addlast EXIT THEN
cur widget parent self cur bind box ?emptybox
cur widget widgets self
cur widget parent with combined add resized endwith ;
: addbefore
cur widget self 0= IF addfirst EXIT THEN
cur widget parent self cur bind box ?emptybox
cur widget self
cur widget parent with combined add resized endwith ;
: addcardfile ( -- o )
cross new 1 $C (makebox panel dup box-name dup
?cardfile
cur box self >r
cur box widgets self cur bind box addlast
r> cur bind box cur box resized ;
: addinstead ( o -- )
cur box self 2dup
cur box parent with combined add combined remove endwith
cur box self cur topbox self = IF dup cur bind topbox THEN
cur box self cur menubox self = IF dup cur bind menubox THEN
cur bind box ;
' addlast IS +object
: cur-box-dpy cur box dpy self ;
: cur-obj-dpy cur widget dpy self ;
' cur-box-dpy is cur-dpy
: addbox ( flag -- ) cur +boxmode !
1 cur +hskip ! 1 cur +vskip !
cross new
1 (addbox +object ;
: redraw cur pane draw cur status draw ;
: rebox ( -- )
cur box childs self
cur box n @ 0 ?DO dup widget with widgets self endwith LOOP
cur box bind childs
cur box n @ (addbox dup >r
& displays @ cur box parent class?
IF
r> cur box parent with
dup cur bind box
assign drop
endwith
ELSE
cur box widgets self
cur box parent self
cur box self cur box parent with combined remove endwith
r@ cur box self update-linked
r@ names find-name
IF names next self names dispose bind names
r@ cur box self names update-hint THEN
cur box self cur topbox self = IF
r@ cur bind topbox
r@ cur resources with
BEGIN
cur box self topbox self = IF dup bind topbox THEN
next-resource self WHILE
next-resource self op!
REPEAT endwith drop
THEN
cur box self cur menubox self = IF
r@ cur bind menubox
r@ cur resources self resource:menu-window with
BEGIN
cur box self menubox self = IF dup bind menubox THEN
next-resource self WHILE
next-resource self op!
REPEAT endwith drop
THEN
0 cur box n ! cur box dispose
r> cur bind box
combined with add resized endwith
THEN ;
: ?cur-box cur box self 0= IF rdrop THEN ;
: ?cur-box:0 cur box self 0= IF 0 rdrop THEN ;
: box-low ( -- o )
0 TS[ 1 and cur +hskip ! ?cur-box
cur +hskip @ cur box hskip c! cur box resized ][
?cur-box:0 cur box hskip c@ dup cur +hskip ! 0<> ]TS
s" hskip" tbutton new
0 TS[ 1 and cur +vskip ! ?cur-box
cur +vskip @ cur box vskip c! cur box resized ][
?cur-box:0 cur box vskip c@ dup cur +vskip ! 0<> ]TS
s" vskip" tbutton new
0 TS[ 2 and cur +borderw ! ?cur-box
cur +borderw @ cur box borderw c! cur box resized ][
?cur-box:0 cur box borderw cx@ dup cur +borderw !
0<> ]TS
s" border" tbutton new
0 1 *fill 2dup glue new
4 vabox new ;
: box-detail ( -- o )
0 [: cur +hskip ! ?cur-box
cur +hskip @ cur box hskip c! cur box resized ;]
[: ?cur-box:0 cur box hskip c@ dup cur +hskip ! ;]
9 scale-act new TT" hskip" hscaler new
0 [: cur +vskip ! ?cur-box
cur +vskip @ cur box vskip c! cur box resized ;]
[: ?cur-box:0 cur box vskip c@ dup cur +vskip ! ;]
9 scale-act new TT" vskip" hscaler new
0 [: cur +borderw ! ?cur-box
cur +borderw @ cur box borderw c! cur box resized ;]
[: ?cur-box:0 cur box borderw cx@ dup cur +borderw ! ;]
#18 scale-act new TT" border" hscaler new
hscaler with #-9 offset ! ^ endwith
0 1 *fill 2dup glue new
4 vabox new ;
: >hfbox ( o flag -- o o +do -do )
>r 1 habox new r@ 0= IF flipbox THEN dup
r> flipper ;
: box-setting ( -- o )
box-low -1 >hfbox s" Low" topindex new >r
box-detail 0 >hfbox s" Details" topindex new >r
2 habox new 2 borderbox :notshadow noborderbox
r> r> swap 2 harbox new swap
2 vabox new vfixbox ;
: box-attr! ( flag attr -- ) >r
cur box attribs c@ swap
IF r> or ELSE r> invert and THEN
cur box attribs c! cur box resized ;
: box-attr@ ( attr -- flag )
cur box attribs c@ and 0<> ;
: boxes ( -- o )
backing new D[ \ backing noback on
0 TS[ cur +boxmode ! rebox ][
?cur-box:0
cur box self ?hbox dup cur +boxmode !
cur box attribs c@ $F0 and cur +noborder ! ]TS
TT" toggle horizontal/vertical box"
s" horizontal" tbutton new
0 TS[ cur +activate ! rebox ][
?cur-box:0
cur box self ?abox dup cur +activate ! ]TS
TT" toggle single active object/all objects active"
s" activate" tbutton new
0 TS[ cur +radio ! rebox ][
?cur-box:0
cur box self ?rbox dup cur +radio ! ]TS
TT" toggle radio button behavior"
s" radio" tbutton new
0 TS[ cur +tabbing ! rebox ][
?cur-box:0
cur box self ?tbox dup cur +tabbing ! ]TS
TT" toggle tabbing the box (all widgets equal size)"
s" tabbing" tbutton new
0 TS[ cur +tabular ! rebox ][
?cur-box:0
cur box self ?table dup cur +tabular ! ]TS
TT" toggle tabular box (table in outer box)"
s" tabular" tbutton new
0 TS[ dup cur +hfixbox ! :hfix box-attr!
][ ?cur-box:0 :hfix box-attr@ dup cur +hfixbox !
]TS TT" horizontal size fixed to minimum"
s" hfixbox" tbutton new
0 TS[ dup cur +vfixbox ! :vfix box-attr!
][ ?cur-box:0 :vfix box-attr@ dup cur +vfixbox !
]TS TT" vertical size fixed to minimum"
s" vfixbox" tbutton new
0 TS[ dup cur +flipbox ! :flip box-attr!
][ ?cur-box:0 :flip box-attr@ dup cur +flipbox !
]TS TT" toggle show/hide box"
s" flipbox" tbutton new
\ 0 TS[ dup cur +rzbox ! :resized box-attr!
\ ][ ?cur-box:0 :resized box-attr@ dup cur +rzbox !
\ ]TS TT" toggle dump resize behavior"
\ s" rzbox" tbutton new
8 vabox new
box-setting
s" box name:" text-label new
t" " 0 ST[ text@ cur cur-box-name update-name ]ST
textfield new dup cur bind cur-box-edit
s" display name:" text-label new
t" " 0 ST[ cur cur-dpy self IF
text@ cur cur-dpy with
descriptors name $! endwith
THEN ]ST
textfield new dup cur bind cur-dpy-edit
4 vabox new
3 vabox new panel 2 borderbox hfixbox vfixbox
dup cur bind status ]D
0 1 *filll 2dup glue new
2 vabox new ;
\ single objexts
: +descs ( o class -- )
>r bind cur-descs
all-descs self cur-descs bind next
cur-descs self bind all-descs
cur-descs null r> new,
dup cur-descs assign ;
: >vfbox ( o flag -- o o +do -do )
>r 1 vabox new r@ 0= IF flipbox THEN dup
r> flipper ;
: 0fill ( -- o ) 0 1 *fill 0 1 *fill glue new ;
include theseus-save.fs
\ groups and entities
Variable entities
: entity, ( -- estart )
here entities @ A, entities ! here
BEGIN source >in @ safe/string -trailing nip WHILE
' >body A,
REPEAT 0 A, ;
: show-field ( -- )
0 bind edit-string
0 bind code-string
0 bind code2-string
0 bind name-string
cur back self backing with
0 1 *fill 0 1 *fill glue new
cur-descs self IF cur-descs edit-field swap 2 ELSE 1 THEN
vabox new assign resized
endwith changed ;
forward new:dialog
: ?cur-box ( -- )
cur self IF cur box self ELSE 0 THEN 0= IF
new:dialog cur pane resized
THEN ;
: new-entity ( addr -- n )
cell+ 0 >r
BEGIN
dup @ WHILE
dup >r @ @ new, r> cell+ r> 1+ >r
REPEAT
drop r> ;
: ?entity ( -- )
?cur-box cur box self 0= IF drop rdrop THEN ;
: +entity ( o class -- ) >r
dup +object
cur bind widget
r> cell+ show-field drop changed ;
: make-entity ( addr -- ) ?entity
dup >r new-entity
descriptors new r@ @ @ +descs
r> +entity ;
: make-font-entity ( addr -- ) ?entity
dup >r new-entity
font-descriptors new r@ @ @ +descs
r> +entity ;
: make-ref-entity ( addr -- ) ?entity
dup >r new-entity
referred-descs new r@ @ @ +descs
r> +entity ;
: make-edit-entity ( addr -- ) ?entity
dup >r new-entity
font-descriptors new r@ @ @ +descs $40 setup-edit
r> +entity ;
: make-component-entity ( -- )
component-des new component-des with
s" no-comp" s" " assign
null endwith dup +object cur bind widget show-field ;
: make-dentity ( addr -- ) ?entity
dup >r new-entity
descriptors new r@ @ @ +descs
displays with cross new 1 habox new assign ^ endwith
r> +entity ;
: make-ventity ( addr -- ) ?entity
dup >r new-entity
descriptors new r@ @ @ +descs
displays with cross new 1 vabox new \ rzbox
assign ^ endwith
dup asliderview new +object
cur bind widget
r> cell+ show-field drop ;
: make-hsentity ( addr -- ) ?entity
dup >r new-entity
descriptors new r@ @ @ +descs 1 hasbox new
r> +entity ;
: make-vsentity ( addr -- ) ?entity
dup >r new-entity
descriptors new r@ @ @ +descs 1 vasbox new
r> +entity ;
Variable #entities
: group #entities off : [defined] discard-sinline [IF] discard-sinline [THEN] ;
: endgroup postpone 0fill #entities @ 1+ postpone Literal
& habox @ postpone ALiteral postpone new,
postpone panel postpone ; ; immediate
: (entity ( addr u -- ) simple new -rot button new ;
[defined] lastdes [IF]
: lastdes-reset $80 lastdes ! ;
[ELSE]
: lastdes-reset ;
[THEN]
: entity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-entity
postpone ;] postpone (entity
1 #entities +!
; immediate
: font-entity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-font-entity
postpone ;] postpone (entity
1 #entities +!
; immediate
: ref-entity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-ref-entity
postpone ;] postpone (entity
1 #entities +!
; immediate
: edit-entity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-edit-entity
postpone ;] postpone (entity
1 #entities +!
; immediate
: component-entity ( -- )
postpone 0
postpone [: postpone make-component-entity
postpone ;] postpone (entity
1 #entities +!
; immediate
: dentity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-dentity
postpone ;] postpone (entity
1 #entities +!
; immediate
: ventity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-ventity
postpone ;] postpone (entity
1 #entities +!
; immediate
: hsentity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-hsentity
postpone ;] postpone (entity
1 #entities +!
; immediate
: vsentity ( -- )
postpone AHEAD entity, >r lastdes-reset postpone THEN
postpone 0
postpone [: r> postpone ALiteral postpone make-vsentity
postpone ;] postpone (entity
1 #entities +!
; immediate
\ object description:
group buttons:
s" Button" font-entity button simple-des string-des
s" LButton" font-entity lbutton simple-des string-des
s" Icon-Button" font-entity icon-button simple-des icon-des string-des
s" Icon" font-entity icon-but simple-des icon-des
s" Big-Icon" font-entity big-icon simple-des icon-des string-des
s" Tri-Button" entity tributton simple-des tri-des
endgroup
group toggles:
s" Toggle" font-entity tbutton toggle-des string-des
s" Radio" font-entity rbutton toggle-des string-des
s" Flip" font-entity flipbutton toggle-des string-des
s" Togglebutton" font-entity togglebutton toggle-des string-des text-des
s" Icon" font-entity toggleicon toggle-des 2icon-des
s" Flip-Icon" font-entity flipicon toggle-des icon-des
s" Iconbutton" font-entity ticonbutton toggle-des 2icon-des string-des
s" Topindex" ref-entity topindex index-des string-des
endgroup
group fields:
s" Text" font-entity textfield text-des stroke-des
s" Infotext" font-entity infotextfield text-des stroke-des string-des
s" Tab-Infotext" font-entity tableinfotextfield text-des stroke-des string-des
s" Number" font-entity textfield number-des nstroke-des
s" Infonumber" font-entity infotextfield number-des nstroke-des string-des
s" Tab-Infonumber" font-entity tableinfotextfield number-des nstroke-des string-des
s" Float" font-entity textfield float-des fstroke-des
s" Infofloat" font-entity infotextfield float-des fstroke-des string-des
s" Tab-Infofloat" font-entity tableinfotextfield float-des fstroke-des string-des
endgroup
group slides:
s" Hslider" entity hslider slider-des slider-code
s" Hslider0" entity hslider0 slider-des slider-code
s" Hscaler" font-entity hscaler scaler-des scaler-code
s" Vslider" entity vslider slider-des slider-code
s" Vslider0" entity vslider0 slider-des slider-code
s" Vscaler" font-entity vscaler scaler-des scaler-code
endgroup
group labels:
0 [: hvline dup *hvglue with 4 hmin ! endwith +object ;] simple new s" Line"
button new [ 1 #entities +! ]
s" Label"
font-entity text-label string-des
s" Icon"
entity icon icon-des
endgroup
group sizer:
s" Hrtsizer" hsentity hrtsizer
s" Hsizer" hsentity hsizer
s" Hxrtsizer" hsentity hxrtsizer
s" Vrtsizer" vsentity vrtsizer
s" Vsizer" vsentity vsizer
s" Vxrtsizer" vsentity vxrtsizer
endgroup
\ object creator
group menues:
s" Menu-Title" font-entity menu-title menu-des string-des
s" Info-Menu" font-entity info-menu menu-des string-des
s" Sub-Menu" font-entity sub-menu menu-des string-des
s" Menu-Entry" font-entity menu-entry action-des string-des
0 [: hvline dup *hvglue with 4 hmin ! endwith +object ;] simple new s" Line"
button new [ 1 #entities +! ]
endgroup
group displays:
s" Viewport" ventity viewport step-des viewport-des
s" HViewport" ventity hviewport step-des viewport-des
s" VViewport" ventity vviewport step-des viewport-des
s" Backing" dentity backing display-des
s" Doublebuffer" dentity doublebuffer display-des
s" Clipper" dentity clipper display-des
s" Beamer" dentity beamer beam-des display-des
endgroup
group glues: ( -- o )
s" Glue" entity glue hglue-des vglue-des
s" HGlue" entity *hglue hglue-des
s" VGlue" entity *vglue vglue-des
s" HVGlue" entity *hvglue hglue-des
s" Rule" entity rule hglue-des vglue-des
s" HRule" entity hrule hglue-des
s" VRule" entity vrule vglue-des
s" HVRule" entity hvrule hglue-des
s" Topglue" entity topglue topglue-des
endgroup
group complex:
s" Canvas" entity canvas canvas-des click-des hglue-des vglue-des
s" OpenGL Canvas" entity glcanvas glcanvas-des click-des hglue-des vglue-des
s" Terminal" font-entity terminal term-des
s" Editor" edit-entity stredit edit-des
s" Component" component-entity
endgroup
: classes ( -- o )
backing new D[
displays: 0 >vfbox s" Displays" topindex new >r
complex: 0 >vfbox s" Complex" topindex new >r
glues: 0 >vfbox s" Glues" topindex new >r
labels: 0 >vfbox s" Labels" topindex new >r
sizer: 0 >vfbox s" Sizer" topindex new >r
menues: 0 >vfbox s" Menues" topindex new >r
slides: 0 >vfbox s" Sliders" topindex new >r
fields: 0 >vfbox s" Text Fields" topindex new >r
toggles: 0 >vfbox s" Toggles" topindex new >r
buttons: -1 >vfbox s" Buttons" topindex new >r
#10 vabox new 2 borderbox :notshadow noborderbox
r> r> r> r> r> r> r> r> r> r>
topglue new
#11 harbox new swap
2 vabox new
0 S[ ?cur-box true addbox ]S s" hbox" button new
0 1 *fil 2dup glue new
0 S[ ?cur-box false addbox ]S s" vbox" button new
3 vabox new 1 vabox new panel 2 borderbox
2 habox new
vfixbox ]D ;
\ load file
include theseus-load.fs
\ modes
: find-box ( o -- o' )
BEGIN
dup all-descs find-object WHILE
dup 'nil <> WHILE
gadget with widgets self endwith
REPEAT THEN ;
: up-box ( o -- up-o )
widget with
& displays @ class?
IF & viewport @ class?
IF parent parent parent parent self
ELSE parent self THEN
ELSE self THEN
endwith ;
: go-up ( -- )
cur box self cur topbox self = ?EXIT
cur box self cur menubox self = ?EXIT
cur box parent self up-box
cur bind box <rebox> redraw ;
: go-down ( -- )
cur box childs self find-box
dup 'nil <>
over widget with & combined @ class? endwith and
IF cur bind box <rebox> redraw ELSE drop THEN ;
: go-right ( -- )
cur box widgets self find-box
dup 'nil <> IF cur bind box ELSE drop THEN
<rebox> redraw ;
: go-left ( -- )
cur box self >r
cur box parent self >child
find-box
BEGIN dup r@ <> WHILE
dup 'nil <> IF cur bind box ELSE 2drop rdrop EXIT THEN
cur box widgets self find-box
REPEAT drop <rebox> redraw rdrop ;
forward find-object
: ?backing ( -- o )
^ backing with
& backing @ class?
IF
trans child self find-object
?dup 0= IF
child self >child
THEN
ELSE
^
THEN
endwith ;
: find-object ( x y o -- x y o/0 )
combined with
2dup inside? IF
^ all-descs find-object
IF
?backing
ELSE
& sliderview @ class?
IF sliderview inner self op! THEN
& combined @ class?
IF
childs self >r
BEGIN
r@ recurse
dup 0= WHILE
drop r> widget with widgets self endwith
dup >r 'nil = UNTIL 0 THEN
rdrop
?dup 0= IF ^ THEN
ELSE
?backing
THEN
THEN
ELSE
0
THEN
endwith ;
: >object ( x y b n -- x y o )
2drop 2dup cur inside
0= IF drop 2drop rdrop false EXIT THEN
find-object dup 0= IF drop rdrop false EXIT THEN ;
: (click-edit ( x y b n -- flag ) >object
dup all-descs find-object 0=
over widget with & combined @ class? endwith and
IF
cur bind box drop redraw EXIT
ELSE
dup widget with parent self endwith cur bind box redraw
THEN
dup cur widget self = IF drop 2drop true EXIT THEN
dup all-descs find-object dup 0=
IF 2drop 2drop false ( redraw ) EXIT THEN
bind cur-descs cur bind widget
show-field ( redraw ) 2drop true ;
: click-edit ( x y b n -- )
edit-string self 0= ?EXIT
edit-string xywh p+ 1 1 p- edit-string dpy transback
1 2 edit-string dpy dpy clicked
$FF57 0 edit-string keyed ;
: click-code ( x y b n -- )
code-string self 0= ?EXIT
code-string xywh p+ 1 1 p- code-string dpy transback
1 2 code-string dpy dpy clicked
$FF57 0 code-string keyed ;
: click-name ( x y b n -- )
name-string self 0= ?EXIT
name-string xywh p+ 1 1 p- name-string dpy transback
1 2 name-string dpy dpy clicked
$FF57 0 name-string keyed ;
: click-ecn ( x y b n -- ) over >r (click-edit
IF
r@ 1 and IF click-edit rdrop EXIT THEN
r@ 2 and IF click-code rdrop EXIT THEN
r@ 4 and IF click-name rdrop EXIT THEN
THEN
rdrop ;
: key-edit ( key sh -- ) edit-string self 0= ?EXIT
edit-string keyed ;
: key-code ( key sh -- ) code-string self 0= ?EXIT
code-string keyed ;
: key-name ( key sh -- ) name-string self 0= ?EXIT
name-string keyed ;
widget ptr cut-stack
: up-cut ( o -- up-o )
widget with
& displays @ parent class?
IF & viewport @ parent class?
IF parent parent parent parent self
ELSE parent self THEN
ELSE self THEN
endwith ;
: remove-me ( o -- )
widget with
^ parent self combined with remove
n @ 0= IF cross new 'nil add resized THEN
endwith
cut-stack self bind widgets
^ F bind cut-stack
endwith ;
: is-parent? ( o1 o2 -- flag )
dup 0= IF 2drop false EXIT THEN
BEGIN 2dup <> over cur topbox self <> and WHILE
widget with parent self endwith
dup 0= UNTIL 2drop false EXIT THEN
2drop true ;
: click-cut ( x y o -- )
dup widget with & displays @ parent class? endwith
IF up-cut
ELSE dup widget with & cross @ class? endwith
IF widget with parent self up-cut endwith THEN
THEN
dup cur topbox self = IF drop 2drop EXIT THEN
dup cur menubox self = IF drop 2drop EXIT THEN
dup cur box self is-parent?
IF cur topbox self cur bind box THEN
dup cur widget self is-parent? IF
0 cur bind widget 0 bind cur-descs show-field
THEN
remove-me 2drop ;
: click-copy ( o -- ) drop ;
: click-paste ( x y o -- )
cut-stack self 0= IF drop 2drop EXIT THEN
combined with
cut-stack self
cut-stack widgets self F bind cut-stack
o@ & cross @ =
IF
'nil parent self op!
ELSE
^ all-descs find-object
IF xywh p2/ p+
& vbox @ parent class?
IF nip 2 pick ELSE drop 3 pick THEN
< IF widgets self ELSE self THEN
parent self op!
ELSE
& vbox @ class?
IF
over childs self
n @ 0 ?DO widget with
dup xywh p2/ p+ nip <
IF self true ELSE widgets self false THEN
endwith ?LEAVE dup 'nil = ?LEAVE LOOP nip
ELSE
2 pick childs self
n @ 0 ?DO widget with
dup xywh p2/ p+ drop <
IF self true ELSE widgets self false THEN
endwith ?LEAVE dup 'nil = ?LEAVE LOOP nip
THEN
THEN
THEN
add
childs self @ & cross @ =
IF childs self remove THEN
!resized resized
endwith 2drop ;
: click-ccp ( x y b n -- ) over >r >object
r@ 1 and IF click-cut rdrop EXIT THEN
r@ 2 and IF click-paste rdrop EXIT THEN
r@ 4 and IF click-paste rdrop EXIT THEN
drop rdrop ;
: click-try vabox :: clicked ;
: key-try vabox :: keyed ;
: click-all ( x y b n -- )
kbshift @ 4 and IF click-try EXIT THEN
kbshift @ 1 and IF click-ccp EXIT THEN
click-ecn ;
[defined] x11 [IF]
also xconst
Create do-edit ' click-all A, ' key-edit A, XC_crosshair ,
previous
[THEN]
[defined] win32 [IF]
also win32api
Create do-edit ' click-all A, ' key-edit A, IDC_IBEAM ,
previous
[THEN]
do-edit do-it !
also dos
Variable $acc
: +$ ( addr u -- ) $acc $+! ;
: auto-save-add ( --- )
cur file-name @ IF cur file-name $@ '/' -scan +$ THEN
s" .#" +$
cur file-name @ IF cur file-name $@ 2dup '/' -scan nip safe/string +$ THEN
base push hex cur self dup $10 >> + $FFFF and dup $8 >> + $FF and
0 <<# '#' hold #S '-' hold #> +$ #>> ;
: auto-save-name ( -- addr u )
s" " $acc $! auto-save-add
$acc $@ ;
: auto-save-minos
auto-save-name dump-file
cur save-state @ IF 1 cur save-state ! THEN ;
: run-minos
cur save-state @ IF auto-save-minos THEN
0 arg $acc $! s" '" $acc $+!
cur save-state @ cur file-name @ 0= or
IF auto-save-add
ELSE cur file-name $@ +$ THEN s" '" +$
[defined] win32 [ 0= ] [IF]
s" &" +$
[THEN]
$acc $@ drop system drop ;
Create quote 1 c, '"' c,
: mod-minos
s" Create Module:" s" " s" *.fm"
0 S[ path+file
'.' -scan 1- 2dup 2dup '/' -scan nip safe/string
s" theseus-test" dump-file
s" " $acc $!
s' xbigforth -e "' +$ quote count +$ S" minos openw forth " +$
s" false to script? " +$
s" module " +$ 2dup +$
s" include theseus-test main: main ; MODULE;" +$
s" m' " +$ +$ s" savemod " +$ +$
s' bye"' +$ quote count +$
$acc $@ drop system drop ]S fsel-dialog ;
Variable ren-files
Variable auto-save-file
: rename-old ( addr u -- )
ren-files $! s" ~" ren-files $+!
ren-files $@ 1- ren-files $@ rename-file drop ;
: rename-save ( addr u -- )
ren-files $! s" +" ren-files $+!
ren-files $@ ren-files $@ 1- rename-file drop ;
: set-title ( -- )
cur with
s" 螛畏蟽蔚蠉蟼: " window title! file-name $@ title+!
endwith ;
: try-save ( -- )
s" +" cur file-name $+!
[: cur file-name $@ dump-file ;] catch
cur file-name $@len 1- cur file-name $!len
0= IF
cur file-name $@ rename-old
cur file-name $@ rename-save
auto-save-file dup @ IF $@ delete-file drop ELSE drop THEN
cur save-state off
THEN ;
: save-minos...
s" Save as:" s" " s" *.m"
cur self S[ ^ bind cur ( s" .m" ?suffix )
auto-save-name auto-save-file $!
path+file
cur file-name $! set-title
try-save ]S
fsel-dialog ;
: save-minos
cur file-name @ 0= IF save-minos... EXIT THEN
try-save set-title ;
: append-modes ( -- o )
0 false T[ ['] addfirst F IS +object ['] cur-box-dpy F IS cur-dpy ][ ]T
TT" Add first in box"
icon" icons/head" flipicon new
0 true T[ ['] addlast F IS +object ['] cur-box-dpy F IS cur-dpy ][ ]T
TT" Add last in box"
icon" icons/tail" flipicon new
0 false T[ ['] addbefore F IS +object ['] cur-obj-dpy F IS cur-dpy ][ ]T
TT" Add before current object"
icon" icons/before" flipicon new
0 false T[ ['] addafter F IS +object ['] cur-obj-dpy F IS cur-dpy ][ ]T
TT" Add after current object"
icon" icons/after" flipicon new
4 varbox new vfixbox ;
: navigation ( -- o )
0fill 0 ['] go-up simple new
TT" Up in hierarchy"
1 tributton new 0fill 3 habox new
0fill 0 ['] go-left simple new
TT" Previous in hierarchy"
0 tributton new
2skip 0 ['] go-right simple new
TT" Next in hierarchy"
2 tributton new 0fill 5 habox new
0fill 0 ['] go-down simple new
TT" First child in hierarchy"
3 tributton new 0fill 3 habox new
3 vabox new vfixbox ;
: file-io ( -- o )
0 ['] load-minos simple new
TT" Load file..."
icon" icons/load" icon-but new
0 ['] save-minos simple new
TT" Save"
icon" icons/save" icon-but new
0 ['] run-minos simple new
TT" Run application"
icon" icons/run" icon-but new
0 ['] mod-minos simple new
TT" Save as module"
icon" icons/mod" icon-but new
4 vabox new vfixbox ;
: modes ( -- o )
backing new D[
[defined] edit-modes [IF]
edit-modes
hline
[THEN]
append-modes
hvline
navigation
hvline
file-io
[defined] edit-modes [IF] 7 [ELSE] 5 [THEN]
vabox new 2 borderbox ]D
0fill
2 vabox new hfixbox ;
: designer-file ( -- )
s" Load:" s" " s" *.m"
cur self S[ ^ bind cur
cur callwind self bind term
designer open-file ]S fsel-dialog ;
: file-menu ( -- o )
^ S[ load-minos ]S s" Load file..." menu-entry new
^ S[ save-minos... ]S s" Save as..." menu-entry new
^ S[ run-minos ]S s" Run application" menu-entry new
^ S[ mod-minos ]S s" Save as module..." menu-entry new
hline
^ S[ cur callwind self bind term designer open ]S
s" New designer" menu-entry new
\ ^ S[ designer-file ]S
\ s" Load to new designer..." menu-entry new
hline
^ S[ cur close ]S s" Quit" menu-entry new
8 vabox new 2 borderbox ;
: edit-menu ( -- o )
^ S[ new:dialog cur pane !resized ]S s" New Dialog" menu-entry new
^ S[ new:menu-window cur pane !resized ]S s" New Menu Window" menu-entry new
2 vabox new 2 borderbox ;
[defined] gpl-about 0= [IF]
[defined] VFXforth [if]
include vfx-lgpl-about.m
[else]
include gpl-about.m
[then]
[THEN]
include theseus-help.m
also dos
: help-menu ( -- o )
[defined] win32 [IF]
^ S[ 0" help/theseus.html" system drop ]S
[ELSE]
^ S[ 0" ${BROWSER-/usr/local/lib/bigforth/help/netscape.sh} http://www.jwdt.com/~paysan/help/theseus.html >/dev/null 2>/dev/null &" system drop ]S
[THEN]
s" Using Theseus" menu-entry new
hline
^ S[ minos-about open ]S s" About Theseus" menu-entry new
3 vabox new 2 borderbox ;
previous
: designer-menu ( -- o )
file-menu s" File " menu-title new
edit-menu s" Edit " menu-title new
0 1 *fill 2dup rule new
help-menu s" Help " menu-title new
4 hbox new 2 borderbox vfixbox ;
designer implements
: init super init +activate on ;
: open-file ( -- )
open load-minos ;
: close save-state @ 0= IF super close EXIT THEN
[defined] NewTask [IF] $8000 $3000 NewTask activate [THEN]
s" Data may have been modified!"
s" Really want to close?"
2 s" No" s" Yes" 2 1 alert
1 = IF save-state off super close THEN ;
: click ( x y b n -- ) bind-cur super click ;
: keyed ( key sh -- ) bind-cur super keyed ;
: inside ( x y -- o flag )
topbox self IF
2dup topbox inside? IF 2drop topbox self true EXIT THEN
THEN
menubox self IF
2dup menubox inside? IF 2drop menubox self true EXIT THEN
THEN
2drop 0 false ;
: open ( -- )
screen self new dup F bind cur op!
term self bind callwind
designer-menu
classes
modes
1 1 viewport new DS[
^ cur bind pane
0 1 *filll 2dup rule new
dup rule with $D assign endwith
dup cur bind end-rule
1 vabox new ]DS
1 vabox new 2 borderbox panel 2 habox new
2 vabox new
boxes
2 habox new
vrtsizer new
1 1 viewport new dup cur bind back
DS[ 2fill 2fill minos-icon
[ also minos ] icon new [ previous ]
2fill 3 habox new 2fill 3 vabox new ]DS
2 vasbox new dup >r
2 0 modal new 0 hskips 0 vskips
s" Theseus" assign
r> vasbox with xN 7 * xS #16 * + dpy xrc hM @ 6 * + xS 3 * 2/ + vsize !
resized endwith
minos-win set-icon
resized show ;
class;
\ include theseus-try.fs
\ : run-here ( -- )
\ s" minos-test" dump-file
\ s" minos-test" included
\ s" marker forget-it dialog open forget-it" evaluate ;
previous previous previous previous previous previous
also -options definitions
: --theseus ( addr u -- )
2dup dup 2- safe/string s" .m" str= IF included-minos 2
ELSE [defined] defers [IF] defers -i [ELSE] --include [THEN] THEN ;
' --theseus IS -i
previous theseus definitions
[defined] VFXForth [IF]
Module;
also theseus synonym designer designer previous
[ELSE]
export theseus designer ;
Module;
[THEN]
script? [IF] minos openw forth designer open [THEN]