\ MINOS file format parser/loader

Vocabulary minos-load

Variable last-file

: parse-string ( addr1 u1 -- addr2 u2 )  dup >r
    source >in @ safe/string 2swap search 0= abort" not found" nip
    source >in @ safe/string rot - dup r> + >in +! ;

: parse-string? ( addr1 u1 -- addr2 u2 flag ) dup >r
    source >in @ safe/string 2swap search 0=
    IF  2drop source >in @ safe/string dup >in +! false
        rdrop EXIT  THEN
    nip source >in @ safe/string rot - dup r> + >in +! true ;

: scan-strings { addr u string }
    BEGIN  addr u parse-string? 0= WHILE
        string $+line refill 0= UNTIL
    ELSE  string $+line  THEN ;

: find-entity ( class -- entity )
    >r 0 0 entities @
    BEGIN  nip nip dup 2@ over r@ = over 0= or  UNTIL
    2drop cell+ rdrop ;

: #classes ( addr -- n )
    0 swap  BEGIN  @+ swap  WHILE  swap 1+ swap  REPEAT  drop ;

: new-desc ( o class -- o )
    >r bind cur-descs
    all-descs self cur-descs bind next
    cur-descs self bind all-descs
    cur-descs make r> new,
    dup cur-descs assign ;

: 'entity, ( "name" -- )  >in @ ' >body find-entity swap >in !
    Create A, ;

: entity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )
    @ >r  r@ cell+ #classes
    descriptors new
    r> @ @ new-desc ;

: fentity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )
    @ >r  r@ cell+ #classes
    font-descriptors new
    r> @ @ new-desc ;

: ref-entity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )
    @ >r  r@ cell+ #classes
    referred-descs new
    r> @ @ new-desc ;

stroke-des ptr last-stroke

: tentity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )
    @ >r  r@ cell+ #classes
    font-descriptors new
    r> @ @ new-desc ;

: dentity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )  @ >r
    display-des new  r@ cell+ #classes
    descriptors new
    r> @ @ new-desc ;

: ventity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )  @ >r
    step-des new step-des with assign ^ endwith
    viewport-des new  r@ cell+ #classes
    descriptors new
    r> @ @ new-desc ;

: tgentity: ( "name" -- ) 'entity,
DOES> ( class1 .. classn -- o )
    @ >r  topglue-des new r@ cell+ #classes
    descriptors new
    r> @ @ new-desc ;

: ?(name) ( addr u -- flag )
    over c@ '(' = >r + 1- c@ ')' = r> and ;

also minos-load definitions

: ^  ;
: ^^ cur pane self ;
: with  drop ;
: endwith ;
: ( ')' parse 2drop ; immediate
: dup dup ;
: cross  postpone cross ; immediate

: M:
    S" " menu-des new menu-des with assign
        parse-name content $!  parse-name 2drop
        self endwith ;
: S[  drop
    S" " simple-des new simple-des with assign
        s"  ]S ( MINOS )" content scan-strings
        0 typ !
        self endwith ;
: R[  drop
    S" " simple-des new simple-des with assign
        s"  ]R ( MINOS )" content scan-strings
        1 typ !
        self endwith ;
: M[  drop
    S" " simple-des new simple-des with assign
        s"  ]M ( MINOS )" content scan-strings
        2 typ !
        self endwith ;
: T[   nip S" " S" "
    toggle-des new toggle-des with assign
        s"  ][ ( MINOS ) " content  scan-strings
        s"  ]T ( MINOS )" content2 scan-strings
        flag !  0 typ ! self
    endwith ;
: TV[   drop S" " S" "
    toggle-des new toggle-des with assign
        s"  ]T[ ( MINOS ) " content  scan-strings
        s"  ]TV ( MINOS )" content2 scan-strings
        1 typ ! self
    endwith ;
: TN[   drop S" " S" "
    toggle-des new toggle-des with assign
        s"  ]T[ ( MINOS ) " content  scan-strings
        s"  ]TN ( MINOS )" content2 scan-strings
        2 typ ! self
    endwith ;
: TS[   drop S" " S" "
    toggle-des new toggle-des with assign
        s"  ][ ( MINOS ) "  content  scan-strings
        s"  ]TS ( MINOS )" content2 scan-strings
        3 typ ! self
    endwith ;
: TB[   drop S" " S" "
    toggle-des new toggle-des with assign
        s"  ]T[ ( MINOS ) " content  scan-strings
        s"  ]TB ( MINOS )" content2 scan-strings
        4 typ ! self
    endwith ;
: CK[  drop
    S" " click-des new click-des with assign
        s"  ]CK ( MINOS )" content scan-strings
        self endwith ;

: ST[   drop S" "
    stroke-des new stroke-des with assign
        s"  ]ST ( MINOS )" content scan-strings self
    endwith ;

: SN[   drop S" "
    nstroke-des new nstroke-des with assign
        s"  ]SN ( MINOS )" content scan-strings self
    endwith ;

: SF[   drop S" "
    fstroke-des new fstroke-des with assign
        s"  ]SF ( MINOS )" content scan-strings self
    endwith ;

: CV[
    canvas-des new canvas-des with s" " assign
        s"  ]CV ( MINOS )" content scan-strings
        self endwith ;

: GL[
    glcanvas-des new glcanvas-des with s" " assign
        s"  ]GL ( MINOS )" content scan-strings
        self endwith ;

: CP[ ( o -- o )
    drop component-des new component-des with
        s"  ]CP ( MINOS )" parse-string cparam $!
        parse-name   cname  $!  parse-name 2drop
        null endwith ;

: ]N ( d -- o ) number-des new number-des with assign self endwith ;
also float
: ]F ( f -- o ) float-des new float-des with assign self endwith ;
previous
: ]TERM ( d -- ) term-des new term-des with assign self endwith ;
: SC[ ( o 0 n -- o o )
    scaler-des new scaler-des with assign pos ! drop self endwith
    scaler-code new scaler-code with s" " assign
        s"  ]SC ( MINOS )" content scan-strings
        self endwith ;
: SC# ( o n -- o )
    over hscaler with offset ! endwith ;

: SL[ ( o p n s -- o o ) 2swap 2drop
    slider-des new slider-des with assign self endwith
    slider-code new slider-code with s" " assign
        s"  ]SL ( MINOS )" content scan-strings
        self endwith ;

: icon" ( -- o )  '"' parse
    icon-des new icon-des with assign self endwith ;
    
: 2icon" ( -- o )  '"' parse '"' parse 2swap
    2icon-des new 2icon-des with assign self endwith ;

: font" ( o -- o )  '"' parse
    new-font over all-descs find-object
    font-descriptors with
        & font-descriptors @ class?  IF  font!  ELSE  drop  THEN
    endwith ;

: *h: ( i -- )  Create ,
    DOES> @ ( n f i -- )
    hglue-des new hglue-des with assign self endwith ;

: *v: ( i -- )  Create ,
    DOES> @ ( n f i -- )
    vglue-des new vglue-des with assign self endwith ;

0 *h: *hpix     1 *h: *hfil     2 *h: *hfill    3 *h: *hfilll
0 *v: *vpix     1 *v: *vfil     2 *v: *vfill    3 *v: *vfilll

: TRI:
    tri-des new tri-des with assign
        self endwith ;

: :left   0 TRI: ;
: :up     1 TRI: ;
: :right  2 TRI: ;
: :down   3 TRI: ;

: :beamer  beam-des new ;

: flipper ( 0 state -- ) index-des new
    index-des with  fstate !  drop self endwith ;

: C[ ( o -- )  base push hex
    s"  ]C ( MINOS )" parse-string all-descs find-name
    descriptors with item self endwith
    2dup new-link
    topindex with callback bind called endwith ;

: D[ ( o -- o ) ;
: ]D ( o1 o2 -- o1 )
    swap backing with  assign
        self endwith ;

: DS[ ( o -- o ) ;
: ]DS ( o1 o2 -- o1 )
    swap backing with  assign
        self endwith
    asliderview new ;

: bind ( o "name" -- )
    >r bl word count r@
    all-descs find-object
    ?dup IF  descriptors with set-name endwith
    ELSE     r@ hint-name new bind names  THEN
    rdrop ;

: ^^bind ( o "name" -- o ) dup bind ;

: S" [char] " parse string-des new string-des with assign
    self endwith ;

: X" [char] " parse string-des new string-des with assign
    self endwith ;

: T" [char] " parse text-des new text-des with assign
    self endwith ;

: TT"  dup >r [char] " parse r> action-des with assign-tip
    endwith ;

Variable last-stredit

: (straction ( -- o )
    edit-des new dup last-stredit ! ;

also editor

: setup-edit ( o n -- )  dup last-stredit @ edit-des with assign endwith
    setup-edit ;

previous

fentity: button
fentity: lbutton
fentity: icon-button
fentity: icon-but
fentity: big-icon
entity: tributton

fentity: tbutton
fentity: rbutton
fentity: flipbutton
fentity: togglebutton
fentity: toggleicon
fentity: flipicon
fentity: ticonbutton
ref-entity: topindex

tentity: textfield
tentity: infotextfield
tentity: tableinfotextfield

fentity: stredit
fentity: terminal

entity: hslider
entity: hslider0
fentity: hscaler
entity: vslider
entity: vslider0
fentity: vscaler

entity: hrtsizer
entity: hsizer
entity: hxrtsizer
entity: vrtsizer
entity: vsizer
entity: vxrtsizer

fentity: menu-title
fentity: info-menu
fentity: sub-menu
fentity: menu-entry

fentity: text-label
entity: icon

entity: glue
entity: *hglue
entity: *vglue
entity: rule
entity: hrule
entity: vrule

entity: canvas
entity: glcanvas

ventity: viewport
ventity: hviewport
ventity: vviewport
dentity: backing
dentity: clipper
dentity: doublebuffer
dentity: beamer

tgentity: topglue

: new ;

previous Theseus definitions

\ Minos load

: add-stream ( addr o -- )
    over HLock over $@ rot codeedit with
        thisline @ DisposHandle
        thisline off rows off $40 cols ! add-lines
        0 0 at edifile off
    endwith HUnLock ;

also dos

: search-dumpstart ( resources -- ) >r
    BEGIN  refill  WHILE
        source s" ( [methodstart] )" search nip nip
        IF
            ')' parse 2drop 1 >in +!
            s" " cur resources methods-content $!
            s"  ( [methodend] )"
            r@ resource:dialog with methods-content endwith
            dup >r scan-strings r>
            r@ resource:dialog with methods-edit self endwith
            add-stream  THEN
        source s" ( [dumpstart] )" search nip nip
    UNTIL  THEN  rdrop ;

: dump-end? ( -- flag )
    source s" ( [dumpend] )" search nip nip ;

: strip-names ( -- )
    all-descs self
    BEGIN  descriptors with name $@ ?(name)
           IF  S" " name $!  THEN
           next self content @ @ endwith  0= UNTIL  drop ;

: prefix? ( addr1 u1 addr2 u2 -- flag )
    tuck >r >r min r> r> compare 0= ;

: postfix? ( addr1 u1 addr2 u2 -- flag )
    tuck >r >r over swap - 0 max safe/string r> r> compare 0= ;

: new:dialog ( -- )
    cur pane with minos:dialog endwith
    cur end-rule parent self
    combined with cur end-rule self add endwith ;

: new:menu-window ( -- )
    cur pane with minos:menu-window endwith
    cur end-rule parent self
    combined with cur end-rule self add endwith ;

: !class-file ( -- )
    last-file @
    IF  last-file $@ file-status nip 0=
        IF  last-file $@ resource:dialog class-file $!  THEN
        last-file $off  THEN ;
        
: !implementation-file ( -- )
    last-file @
    IF  last-file $@ file-status nip 0=
        IF  last-file $@ resource:dialog implementation-file $!  THEN
        last-file $off  THEN ;
        
: create-dialog ( -- )
    bl word drop bl word drop
    new:dialog cur resources self
    bl word count
    rot resource:dialog with
        name-field assign  shown off  !class-file
    endwith ;

: create-menu-window ( -- )
    bl word drop bl word drop
    new:menu-window cur resources self
    bl word count
    rot resource:menu-window with
        name-field assign shown off !class-file
    endwith ;

: add-vars ( -- )
    ')' parse 2drop 1 >in +!
    s" " cur resources var-content $!
    s"  ( [varend] )"
    cur resources var-content dup >r scan-strings
    r> cur resources var-edit self add-stream ;

: set-title ( o -- ) >r  s" "
    BEGIN  2drop refill  WHILE  s'  s" ' parse-string? nip nip
        IF  '"' parse true  ELSE  s" " s" class;" source compare 0=  THEN
        UNTIL  THEN
    r> resource:dialog with
        dup IF  title-field assign  ELSE  2drop  THEN
    endwith ;

: set-title' ( o -- ) >r >in @ >r
    s'  s" ' parse-string? nip nip
    IF  rdrop '"' parse
    ELSE  r> >in !
	s'  X" ' parse-string? nip nip
	IF  '"' parse  ELSE  s" "  THEN
    THEN
    r> resource:dialog with
        dup IF  title-field assign  ELSE  2drop  THEN
    endwith ;

: load-dialog ( o -- )
    \ traceall
    resource:dialog with
        topbox self ^ !implementation-file
    endwith >r
    cur bind box
    r@ search-dumpstart
    cur box dpy with
        BEGIN
            refill  WHILE
            dump-end? 0=  WHILE
            interpret
        REPEAT THEN
    endwith
    r@ resource:dialog with add-box >cur  endwith
    r> set-title ;

: read-titles ( -- )
    BEGIN  refill  WHILE
        source s" open" search nip nip
        IF
            bl word count cur resources find-name ?dup
            IF
                resource:dialog with shown on
                    show-state draw endwith
            THEN
        THEN
    REPEAT ;

: create-classes ( -- )
    reenter dup push on
    BEGIN  refill  WHILE
        true CASE
            source s' " included?' postfix?
            source s' s" ' prefix? and
            OF  bl word drop '"' parse last-file $!  ENDOF
            source s" include " prefix?
            OF  bl word drop bl parse last-file $!  ENDOF
            source s" component class " prefix?
            OF  create-dialog  ENDOF
\ FIXME dated alternatives: to be removed for final version
            source s" window class " prefix?
            OF  create-dialog  ENDOF
            source s" vabox class " prefix?
            OF  create-dialog  ENDOF
            source s" menu-window class " prefix?
            OF  create-menu-window  ENDOF
\ FIXME end dated alternatives
            source s" menu-component class " prefix?
            OF  create-menu-window  ENDOF
            source s" ( [varstart] ) " search nip nip
            OF  add-vars  ENDOF
            source s"   : open-app new DF[ " prefix?
            OF  s"   : open-app new DF[ " >in ! drop bl parse
                2dup s" 0" compare
                IF  cur resources default $!  ELSE  2drop  THEN  ENDOF
            source s"   : params   DF[ " prefix?
            OF  s"   : params   DF[ " >in ! drop bl parse
                2dup s" 0" compare
		IF  cur resources default $!  ELSE  2drop  THEN
		cur resources self  set-title'  ENDOF
            source s"     widget 1 " prefix?
            OF  s"     widget 1 " >in ! drop bl parse
                2dup s" 0" compare
                IF  cur resources default $!  ELSE  2drop  THEN  ENDOF
            source s" implements" search nip nip
            OF 
                bl word count cur resources find-name ?dup
                IF  load-dialog  THEN  ENDOF
            source s" : main" prefix?
            OF  read-titles  ENDOF
        ENDCASE
    REPEAT
    cur pane !resized
    cur pane resized
    cur status resized <rebox> <redpy> ;

also minos-load definitions
[defined] Synonym [IF]
    Synonym #! create-classes
[ELSE]
    ' create-classes Alias #!
[THEN]
previous theseus definitions

[defined] VFXForth [IF] -258 Constant open-failed# [THEN]
[defined] bigForth [IF] -1026 Constant open-failed# [THEN]

: included-minos ( addr u -- )  loading on
    [ also float [defined] f-init [IF] ] f-init [ [THEN] previous ]
    2dup cur file-name $!
    Onlyforth minos also minos-load also
    ['] included catch dup open-failed# <> IF  throw 0  THEN
    IF  2drop  THEN  strip-names Onlyforth cur save-state off
    cur with
        s" Θησεύς: " window title! file-name $@ window title+!
    endwith
    loading off ;

: load-minos ( -- )
    s" Load:" s" " s" *.m"
    cur self S[ ^ bind cur path+file pad place pad count included-minos ]S
    fsel-dialog ;

previous