theseus-desc.fs 28.4 KB
Newer Older
bp's avatar
bp committed
1 2
\ MINOS descriptor classes

bp's avatar
bp committed
3
: .d  base @ >r decimal '#' emit dup 0< IF '-' emit THEN abs . r> base ! ;
bp's avatar
bp committed
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

descriptor class descriptors
public:
    ptr next
    cell var content
    cell var name
    cell var number
    method find-object
    method find-name
    method set-name
    method dump-name
    method dump-class
    method dump-ptr
    method create-ptr
class;

descriptors ptr cur-descs
descriptors ptr all-descs

descriptors implements
    : init ( class1 .. classn n -- )
        s" " name $!
        dup 1+ cells content Handle!
        dup content @ !
        0 ?DO  I' I - cells content @ + !  LOOP ;
    : delete-desc ( -- )
        cur-descs self ^ = IF  0 F bind cur-descs  THEN
        F link all-descs
        BEGIN  dup @ >o next self self o> <> WHILE
            dup @ ^ = IF  next self swap ! EXIT  THEN
            @ >o link next o>  REPEAT  drop ;
    : dispose ( -- )  delete-desc
        content HandleOff  name HandleOff  super dispose ;
    : assign ( o -- )
        dup bind item
        content @ @ 1+ 1 ?DO  dup content @ Ith
            descriptor with bind item endwith  LOOP  drop
        item self 0 update-linker ;
    : null ( -- null1 .. nulln )
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with null endwith  LOOP ;
    : make ( -- make1 .. maken )
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with make endwith  LOOP ;
    : rightcase ( addr1 u1 -- addr2 u2 )
        scratch place
        0 scratch count bounds ?DO
            IF    I c@ dup tolower dup I c! <>
            ELSE  true  THEN
bp's avatar
bp committed
53
        LOOP  drop scratch count 2dup + >r s"  name:" tuck r> swap move + ;
bp's avatar
bp committed
54
    : edit-field ( -- o )
bp's avatar
bp committed
55 56
	name $@ 0 ST[ text@ >current-name ]ST
	item self >class" rightcase
bp's avatar
bp committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
        infotextfield new dup F bind name-string
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with edit-field endwith  LOOP
        content @ @  1+ vabox new panel ;
    : dump ( -- )  cr indent @ spaces
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with dump endwith  LOOP
        item self >class" lctype
        ."  new "  name $@ nip IF  ."  ^^bind " dump-name  THEN
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with post-dump endwith  LOOP ;
    : find-object ( o -- desc-o )
        next self self =  IF  drop 0  EXIT  THEN
        dup item self = IF  drop self  EXIT  THEN
        next goto find-object ;
    : find-name ( addr u -- desc-o )
        next self self = IF  drop 0  EXIT  THEN
        2dup name $@ compare 0= IF  2drop self  EXIT  THEN
        next goto find-name ;
    
    : set-name ( addr u -- )  name $! ;
    : dump-name ( -- )
        name $@ nip IF
            name $@ type
        ELSE
            set-var @ IF  nvar @ number !  1 nvar +!  THEN
            ." (" item self >class" lctype ." -" number @ 0
bp's avatar
bp committed
84
            <<# # # #> type #>> ." )"
bp's avatar
bp committed
85 86 87 88 89 90 91 92 93
        THEN ;
    : dump-class ( -- )
        item self >class" lctype ;
    : dump-ptr ( -- )
        name $@ nip 0=  ?EXIT  \ IF ." | "  THEN
        cr indent @ spaces
        dump-class ."  ptr " dump-name ;
    : create-ptr ( -- )
        name $@ nip IF
94 95
            name $@ [: item ptr >in off
	    item self F postpone bind ;] execute-parsing
bp's avatar
bp committed
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
        THEN ;
class;

Variable tmp-contents

descriptors class font-descriptors
public:
    font ptr fnt
    method font!
    window ptr chooser
how:
    : font! ( font -- )  bind fnt
        fnt self item font!
        item self widget with dpy self endwith
        IF  item resized  THEN ;
    : dump ( -- )  super dump
        fnt self 0= ?EXIT
        fnt with X-font name-string endwith $@
        dup IF  .'  font" ' type .' "'  ELSE  2drop  THEN ;
    : font-selector ( -- )
        fnt self IF  fnt with X-font name-string endwith $@
            ELSE  s" "  THEN
bp's avatar
bp committed
118
        0 ST[ text@ tmp-contents $! ]ST
bp's avatar
bp committed
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
        s" Font:" infotextfield new
        0 1 *fill *hglue new
        ^ S[ tmp-contents $@ nip fnt self 0= and
        IF    tmp-contents $@ X-font new bind fnt
        ELSE  tmp-contents $@ fnt assign  THEN    
        fnt self font! chooser close ]S s"  OK " button new
        ^ S[ chooser close ]S s" Cancel" button new
        ^ S[ 0" xfontsel &" [ also DOS ] system [ previous ] drop ]S
        s" xfontsel" button new
        0 1 *fill *hglue new
        5 hatbox new hskip
        2 vabox new panel
        screen self window new window with
            s" Font Selection" assign show ^
        endwith bind chooser ;
    : edit-field ( -- o )
bp's avatar
bp committed
135 136
	name $@ 0 ST[ text@ >current-name ]ST
	item self >class" rightcase infotextfield new dup
bp's avatar
bp committed
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
        ^ S[ font-selector ]S s" Change Font" button new 1 habox new hfixbox
        2 habox new hskip
        swap F bind name-string
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with edit-field endwith  LOOP
        content @ @  1+ vabox new panel ;
class;

font-descriptors class referred-descs
how:
    : dump-ptr ( -- )
        cr indent @ spaces
        name $@ nip 0= IF ." | "  THEN
        dump-class ."  ptr " dump-name ;
    : dump ( -- )  cr indent @ spaces
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with dump endwith  LOOP
        item self >class" lctype
        ."  new ^^bind " dump-name
        content @ @ 1+ 1 ?DO  content @ Ith
            descriptor with post-dump endwith  LOOP
        fnt self 0= ?EXIT
        .'  font" ' fnt with X-font name-string endwith $@ type .' "' ;
class;

: >current-name cur-descs set-name ;

descriptor class tri-des
public:
    cell var content
how:
    : init ( -- )  0 assign ;
    : assign ( n -- )  content !
        item self 0= ?EXIT
        DELAY  get item assign item draw  changed ;
    : get  ( -- n )  content @ ;

    : edit-field ( -- )
          ^ TN[ 0 content ]T[ content @ assign ]TN S" Left" rbutton new
          ^ TN[ 1 content ]T[ content @ assign ]TN S" Up" rbutton new
          ^ TN[ 3 content ]T[ content @ assign ]TN S" Down" rbutton new
          ^ TN[ 2 content ]T[ content @ assign ]TN S" Right" rbutton new
          $0 $1 *hfill $0 $1 *vfil glue new
bp's avatar
bp committed
180
        #5 harbox new hskip ;
bp's avatar
bp committed
181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
    : null ( -- 0 )  0 ;
    : make ( -- n )  get ;
    : dump ( -- )  get
        :left  case? IF  ." :left "  EXIT  THEN
        :up    case? IF  ." :up "    EXIT  THEN
        :down  case? IF  ." :down "  EXIT  THEN
        :right case? IF  ." :right " EXIT  THEN  .d  ." TRI: " ;
class;

descriptor class string-des
public:
    cell var content
how:
    : init ( -- ) s" String" assign ;
    : dispose ( -- ) content HandleOff super dispose ;
    : assign ( addr n -- )  content $!
        item self 0= ?EXIT
        DELAY get item text!  item resized  changed ;
    : get ( -- addr n )  content $@ ;
    
    : edit-field ( -- o )  ^ F cur bind string
bp's avatar
bp committed
202 203
        get 0 ST[ text@ pad place pad count cur string assign ]ST
        s" String:" infotextfield new
bp's avatar
bp committed
204 205 206
        dup F bind edit-string ;
    : null ( -- addr u )  s" String" ;
    : make ( -- addr u )  get ;
bp's avatar
bp committed
207
    : dump ( -- ) .' X" ' get type .' " ' ;
bp's avatar
bp committed
208 209 210 211 212 213
class;

string-des class text-des
how:
    : init ( -- ) s" Text" assign ;
    : edit-field ( -- o )  ^ F cur bind text
bp's avatar
bp committed
214 215
        get 0 ST[ text@ pad place pad count cur text assign ]ST
        s" Text" infotextfield new
bp's avatar
bp committed
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
    ;
    : assign ( addr n -- )  content $!
        item self 0= ?EXIT
        DELAY get item assign  item resized  changed ;
    : null ( -- addr u )  s" Text" ;
    : dump ( -- ) .' T" ' get type .' " ' ;
class;

string-des class menu-des
how:
    : init ( -- ) s" <menu>" assign ;
    : assign ( addr u -- ) content $! ;
    : null ( -- widget )
        0 S[ ]S s" <empty>" menu-entry new
        1 vabox new 2 borderbox ;
    : make ( -- widget )  null ;
232
    : dump ( -- ) ." M: " get type ."  menu " ;
bp's avatar
bp committed
233
    : edit-field ( -- o )  ^ F cur bind text
bp's avatar
bp committed
234 235
        get 0 ST[ text@ pad place pad count cur text assign ]ST
        s" Menu:" infotextfield new ;
bp's avatar
bp committed
236 237 238 239 240 241 242 243 244 245 246 247
class;

descriptor class char-des
public:
    cell var content
how:
    : init ( -- ) bl assign ;
    : assign ( addr u -- )
        dup 0= IF  2drop content off
        ELSE  1 umin  content move  THEN ;
    : get ( -- addr u ) content 1 ;
    : edit-field ( -- o )  ^ F cur bind string
248
        get 0 ST[ text@ dup 1- 0 max safe/string
bp's avatar
bp committed
249
              cur string assign ]ST
bp's avatar
bp committed
250
        s" Text:" infotextfield new ;
bp's avatar
bp committed
251 252 253 254 255 256 257 258 259 260
    : null ( -- char ) bl ;
    : make ( -- char ) bl ;
    : dump ( -- ) space
        infotextfield with get endwith
        0= IF ." bl" drop ELSE ." '" c@ emit THEN space ;
class;

descriptor class 2char-des
how:
    : edit-field ( -- o )
bp's avatar
bp committed
261 262
        t" +" 0 ST[ ]ST s" On-Char:" infotextfield new
        t" -" 0 ST[ ]ST s" Off-Char:" infotextfield new
bp's avatar
bp committed
263
        2 habox new 1 hskips ;
bp's avatar
bp committed
264 265
    : null ( -- char- char+ ) '-' '+' ;
    : make ( -- char- char+ ) '-' '+' ;
bp's avatar
bp committed
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
    : .char ( char -- )
        0= IF ." bl" drop  ELSE ." '" c@ emit THEN space ;
    : dump ( -- ) space
        habox with
            childs widgets self
            infotextfield with get endwith .char
            childs self infotextfield with get endwith .char
        endwith ;
class;

descriptor class number-des
    2 cells var content
how:
    : get  content 2@ ;
    : assign content 2!
        item self 0= ?EXIT
        DELAY get item assign  item resized  changed ;
    : edit-field ( -- o )
        ^ cur bind num
bp's avatar
bp committed
285
        get 0 SN[ text@ cur num assign ]SN s" Number:"
bp's avatar
bp committed
286
        infotextfield new
287
        dup F bind edit-string ;
bp's avatar
bp committed
288 289 290
    : null ( -- addr u )  0. ;
    : make ( -- addr u ) get ;
    : dump ( -- )  base push decimal
291
        get ." #" 0 d.r ." . ]N ( MINOS ) " ;
bp's avatar
bp committed
292 293
class;

294 295 296 297 298 299 300
also float

descriptor class float-des
    1 floats var content
  how:
    : init ( -- ) null assign ;
    : dispose ( -- ) super dispose ;
bp's avatar
bp committed
301
    : assign ( f -- )  content f!
302 303
        item self 0= ?EXIT
        DELAY get item assign  item resized  changed ;
bp's avatar
bp committed
304
    : get ( -- )  content f@ ;
305 306
    
    : edit-field ( -- o )  ^ F cur bind num
bp's avatar
bp committed
307 308
        get 0 SF[ text@ cur num assign ]SF
        s" Float:" infotextfield new
309
        dup F bind edit-string ;
bp's avatar
bp committed
310
    : null ( -- f ) 0e ;
311
    : make ( -- f )  get ;
bp's avatar
bp committed
312
    : dump ( -- ) base push decimal get fe. ." ]F ( MINOS ) " ;
313 314 315 316
class;

previous

bp's avatar
bp committed
317 318 319 320 321 322 323 324 325 326 327 328
: try-icon ( addr u -- icon )
    2dup icon?  ?dup  IF  nip nip icon@  EXIT  THEN
    dup 9 + NewPtr >r
    r@ 8+ place  icons @ r@ !  r@ cell+ off
    r@ ['] icon@ catch
    0= IF  r> icons !  EXIT  THEN
    drop test-icon r> DisposPtr ;

string-des class icon-des
how:
    : edit-field ( -- o )
        ^ cur bind icon
bp's avatar
bp committed
329 330
        content $@ 0 ST[ text@ cur icon assign ]ST
        s" Icon:" infotextfield new ;
bp's avatar
bp committed
331 332 333 334 335 336 337 338 339 340 341 342 343 344
    : null ( -- icon )  test-icon ;
    : make ( -- icon )  get try-icon ;
    : assign ( addr n -- )  content $!
        item self 0= ?EXIT
        DELAY  make  item assign item resized ;
    : dump ( -- )  .'  icon" ' get type .' " ' ;
class;

icon-des class 2icon-des
public:
    cell var content2
how:
    : edit-field ( -- o )
        ^ cur bind icon
bp's avatar
bp committed
345 346 347 348
        content $@ 0 ST[ text@ cur icon get 2swap 2drop cur icon assign ]ST
        s" On-Icon:" infotextfield new
        content2 $@ 0 ST[ text@ cur icon get 2drop 2swap cur icon assign ]ST
        s" Off-Icon:" infotextfield new
bp's avatar
bp committed
349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370
        2 hatbox new 1 hskips ;
    : null ( -- icon1 icon2 )  off-icon on-icon ;
    : make ( -- icon1 icon2 )  get try-icon >r try-icon r> swap ;
    : get ( -- addr1 u1 addr2 u2 ) content $@ content2 $@ ;
    : assign ( addr1 u1 addr2 u2 -- )
        content2 $! content $!
        item self 0= ?EXIT
        DELAY  make item assign item resized ;
    : dump ( -- )  .'  2icon" ' get type .' "' type .' " ' ;
    : init  s" " super init ;
    : dispose  content2 HandleOff super dispose ;
class;

descriptor class glue-des
public:
    cell var pixels
    cell var fills
    cell var quantity
how:
    : init  $10 pixels !  1 fills !  1 quantity ! ;
    : >assign ( pix fill -- pix fill quan )
        dup 0= IF  0  EXIT  THEN
371 372 373
        dup 1 *fil   1- and 0= IF 1 *fil   /f 1  EXIT  THEN
        dup 1 *fill  1- and 0= IF 1 *fill  /f 2  EXIT  THEN
        dup 1 *filll 1- and 0= IF 1 *filll /f 3  EXIT  THEN
bp's avatar
bp committed
374 375 376 377 378 379 380 381 382 383 384 385
        0 ;
    : null  make ;
    | Create 'fills
      F ' noop A, F ' *fil A, F ' *fill A, F ' *filll A,
    : make  get cells 'fills + perform swap 3 max swap ;
    : get  pixels @ fills @ quantity @ ;
    : assign  quantity ! fills ! pixels ! ;
class;

glue-des class hglue-des
how:
    : edit-field ( -- o ) ^ cur bind hglue
bp's avatar
bp committed
386 387
        pixels @ extend 0 SN[ text@ drop cur hglue get rot drop cur hglue assign ]SN
        s" HPixels:"
bp's avatar
bp committed
388
            infotextfield new
bp's avatar
bp committed
389 390
        fills @  extend 0 SN[ cur hglue get nip text@ drop swap cur hglue assign ]SN
        s" Fills:"
bp's avatar
bp committed
391 392 393 394 395 396 397 398 399 400 401 402 403
            infotextfield new
        ^ TN[ 0 quantity ]T[ get assign ]TN
            s" pixel" rbutton new
        ^ TN[ 1 quantity ]T[ get assign ]TN
            s" fil"   rbutton new
        ^ TN[ 2 quantity ]T[ get assign ]TN
            s" fill"  rbutton new
        ^ TN[ 3 quantity ]T[ get assign ]TN
            s" filll" rbutton new
        4 harbox new hfixbox
        3 habox new hskip ;
    : assign  dup 0< IF  drop 2drop  EXIT  THEN
        super assign  item self 0= ?EXIT
bp's avatar
bp committed
404
        make item with glue w+ ! 5 max glue wmin ! parent resized 
bp's avatar
bp committed
405 406 407 408 409 410 411 412 413 414
        endwith ;
    : dump ( -- ) base push hex
        ." $" pixels @ . ." $" fills @ . quantity @ 0=
        IF  ." *hpix "  EXIT  THEN
        s" *hfilll" drop quantity @ 4 + type space ;
class;

glue-des class vglue-des
how:
    : edit-field ( -- o ) ^ cur bind vglue
bp's avatar
bp committed
415 416
        pixels @ extend 0 SN[ text@ drop cur vglue get rot drop cur vglue assign ]SN
        s" VPixels:"
bp's avatar
bp committed
417
           infotextfield new
bp's avatar
bp committed
418 419
        fills @  extend 0 SN[ cur vglue get nip text@ drop swap cur vglue assign ]SN
        s" Fills:"
bp's avatar
bp committed
420 421 422 423 424 425 426 427 428 429 430 431 432
             infotextfield new
        ^ TN[ 0 quantity ]T[ get assign ]TN
             s" pixel" rbutton new
        ^ TN[ 1 quantity ]T[ get assign ]TN
             s" fil"   rbutton new
        ^ TN[ 2 quantity ]T[ get assign ]TN
             s" fill"  rbutton new
        ^ TN[ 3 quantity ]T[ get assign ]TN
             s" filll" rbutton new
        4 harbox new hfixbox
        3 habox new hskip ;
    : assign  dup 0< IF  drop 2drop  EXIT  THEN
        super assign  item self 0= ?EXIT
bp's avatar
bp committed
433
        make item with glue h+ ! 5 max glue hmin ! parent resized
bp's avatar
bp committed
434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
        endwith ;
    : dump ( -- ) base push hex
        ." $" pixels @ . ." $" fills @ . quantity @ 0=
        IF  ." *vpix "  EXIT  THEN
        s" *vfilll" drop quantity @ 4 + type space ;
class;

descriptor class topglue-des
how:
    : edit-field ( -- o )
        s" Topglue" text-label new ;
    : null  ;
    : make  ;
    : dump  ;
class;

descriptor class term-des
    cell var w
    cell var h
how:
    : init  1 w ! 1 h ! super init ;
    : get   w @ h @ ;
    : assign  2dup h ! w !
      item self IF  item assign  ELSE  2drop  THEN ;
    : null  1 1 ;
    : make  get ;
    : edit-field ( -- o )
        ^ cur bind num
bp's avatar
bp committed
462 463
        w @ 0 0 SN[ text@ drop 1 max cur num get nip cur num assign ]SN
              s" W:"
bp's avatar
bp committed
464
        infotextfield new
bp's avatar
bp committed
465 466
        h @ 0 0 SN[ cur num get drop text@ drop 1 max cur num assign ]SN
              s" H:"
bp's avatar
bp committed
467 468 469 470 471 472 473 474 475 476 477 478 479 480 481
        infotextfield new 2 habox new hskip
    ;
    : dump  base push hex
      ." $" w @ . ." $" h @ . ."  ]TERM " ; 
class;

descriptor class edit-des
    cell var linew
how:
    : get     linew @ ;
    : assign  linew !
        DELAY  get item self stredit with 1+ cols ! resized
        endwith  changed ;
    : edit-field ( -- o )
        ^ cur bind num
482
        get 0 0 SN[ text@ drop cur num assign ]SN s" Line width:"
bp's avatar
bp committed
483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
        infotextfield new ;
    : null (straction  $40 linew ! ;
    : make (straction ;
    : dump ."  (straction " ;
    : post-dump base push hex ."  $" get 0 .r  ."  setup-edit " ;
class;

string-des class action-des
public:
    method assign-tip
    method get-tip
    method add-code
    cell var tooltip-string
    codeedit ptr code-lines
how:
    : get-tip    ( -- addr u )  tooltip-string $@ ;
    : assign-tip ( addr u -- )  tooltip-string $! ;
    : add-code   ( addr u -- )  content $+line ;
    : tooltip-field ( -- o )
bp's avatar
bp committed
502 503
        get-tip 0 ST[ text@ cur action with assign-tip endwith ]ST
        s" Tooltip:" infotextfield new ;
bp's avatar
bp committed
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
    : edit-field ( -- o )  ^ F cur bind action
        s" Code:" text-label new
        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 habox new
        tooltip-field 2 vabox new vskip ;
    : assign ( addr n -- )  content $! ;
    : null ( -- actor ) 0 ['] noop simple new ;
    : make ( -- actor ) 0 ['] noop simple new ;
    : dump-tooltip ( -- )
        tooltip-string $@ nip
        IF  .'  TT" ' tooltip-string $@ type .' " '  THEN ;
    : dump ( -- ) ." ^^ S[ " get type ."  ]S ( MINOS ) " dump-tooltip ;
    : init ( addr u -- ) s" " tooltip-string $!  s" " assign ;
    : dispose  tooltip-string HandleOff  code-lines dispose super dispose ;
class;

action-des class click-des
how:
    : init ( -- ) s" " tooltip-string $!
        s" ( x y b n -- ) 2drop 2drop" assign ;
    : dump ( -- ) ." ^^ CK[ " get type ."  ]CK ( MINOS ) " ;
class;

534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556
action-des class simple-des
    cell var typ
  how:
    : edit-field ( -- o )  ^ F cur bind action
	0 TN[ 0 typ ]T[ ]TN s" Simple" rbutton new
	0 TN[ 1 typ ]T[ ]TN s" Repeat" rbutton new
	0 TN[ 2 typ ]T[ ]TN s" Drag" rbutton new
	cur back with 2fill endwith 4 hartbox new
        s" Code:" text-label new
        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 habox new
	tooltip-field 3 vabox new vskip ;
    : .srm s" SRM" drop typ @ + c@ emit ;
    : dump ( -- ) ." ^^ " .srm ." [ "
	get type ."  ]" .srm ."  ( MINOS ) " dump-tooltip ;
class;
bp's avatar
bp committed
557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
action-des class canvas-des
how:
    : edit-field ( -- o )  ^ F cur bind action
        s" Draw:" text-label new
        0 1 *fill 2dup glue new
        2 vabox new
        content HLock
        get content new-code dup bind code-lines
        dup F bind edit-string
        content HUnLock
        1 habox new -2 borderbox
        0 1 *fill 2dup glue new
        3 habox new ;
    : null ( -- actor ) CV[ ]CV ;
    : make ( -- actor ) null ;
    : dump ( -- ) ." CV[ " get type ."  ]CV ( MINOS ) " ;
class;

canvas-des class glcanvas-des
how:
    : null ( -- actor ) GL[ ]GL ;
    : make ( -- actor ) null ;
    : dump ( -- ) ." GL[ " get type ."  ]GL ( MINOS ) " ;
class;

action-des class stroke-des
how:
    : edit-field ( -- o )  ^ F cur bind action
        s" Dostroke:" text-label new
        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 habox new ;
    : assign ( addr n -- )  content $! ;
    : null ( -- ) 0 ST[ ]ST ;
    : make ( -- ) null ;
    : dump ( -- )
        ." ^^ ST[ " get type ."  ]ST ( MINOS ) " ;
    : post-dump ( -- ) ;
class;

action-des class nstroke-des
how:
    : edit-field ( -- o )  ^ F cur bind action
        s" Dostroke:" text-label new
        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 habox new ;
    : assign ( addr n -- )  content $! ;
    : null ( -- ) 0 SN[ ]SN ;
    : make ( -- ) null ;
    : dump ( -- )
        ." ^^ SN[ " get type ."  ]SN ( MINOS ) " ;
    : post-dump ( -- ) ;
class;

624 625
nstroke-des class fstroke-des
  how:
bp's avatar
bp committed
626 627
    : null ( -- ) 0 SF[ ]SF ;
    : make ( -- ) null ;
628
    : dump
bp's avatar
bp committed
629
        ." ^^ SF[ " get type ."  ]SF ( MINOS ) " ;
630 631
class;

bp's avatar
bp committed
632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
descriptor class display-des
how:
    : edit-field ( -- o )
        s" Display" text-label new ;
    : assign ( object -- )
        item self 0= IF  drop  EXIT  THEN
        item assign ;
    : null ( -- ) ;
    : make ( -- ) ;
    : dump ( -- ) ;
    : post-dump ( -- ) ."  D[ "
        item self backing with child self endwith dump-box
        ."  ]D ( MINOS ) " ;
class;

display-des class viewport-des
how:
    : post-dump ( -- ) ."  DS[ "
        item self backing with child self endwith dump-box
        ."  ]DS ( MINOS ) " ;
class;

bp's avatar
bp committed
654 655
Create toggle-on$  ," On-Xt ( -- ):" ," Var ( -- addr ):" ," Num Var ( -- n addr ):" ," Fetch-Xt ( -- flag ):" ," Bit ( -- addr n ):"
Create toggle-off$ ," Off-Xt ( -- ):" ," Change-Xt ( -- ):" ," Change-Xt ( -- ):" ," Store-Xt ( flag -- ):" ," Change-Xt ( -- ):"
bp's avatar
bp committed
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674

: typ$ ( addr n -- addr' u )  0 ?DO  count +  LOOP  count ;

descriptor class toggle-des
public:
    method assign-tip
    method get-tip
    cell var flag
    cell var content
    cell var content2
    cell var tooltip-string
    cell var typ
how:
    : init ( -- ) s" " s" " assign s" " tooltip-string $! ;
    : dispose  content HandleOff  content2 HandleOff  tooltip-string HandleOff
        super dispose ;
    : get-tip    ( -- addr u )  tooltip-string $@ ;
    : assign-tip ( addr u -- )  tooltip-string $! ;
    : tooltip-field ( -- o )
bp's avatar
bp committed
675 676
        get-tip 0 ST[ text@ cur toggle with assign-tip endwith ]ST
	s" Tooltip:" infotextfield new ;
bp's avatar
bp committed
677 678
    : edit-field ( -- o )
        ^ F cur bind toggle
bp's avatar
bp committed
679 680
        0 TN[ 0 typ ]T[ toggle-on$  0 typ$ code-string text!
                        toggle-off$ 0 typ$ code2-string text! ]TN
bp's avatar
bp committed
681
            s" Toggle" rbutton new
bp's avatar
bp committed
682 683
        0 TN[ 1 typ ]T[ toggle-on$  1 typ$ code-string text!
                        toggle-off$ 1 typ$ code2-string text! ]TN
bp's avatar
bp committed
684
            s" Toggle-Var" rbutton new
bp's avatar
bp committed
685 686
        0 TN[ 2 typ ]T[ toggle-on$  2 typ$ code-string text!
                        toggle-off$ 2 typ$ code2-string text! ]TN
bp's avatar
bp committed
687
            s" Toggle-Num" rbutton new
bp's avatar
bp committed
688 689
        0 TN[ 3 typ ]T[ toggle-on$  3 typ$ code-string text!
                        toggle-off$ 3 typ$ code2-string text! ]TN
bp's avatar
bp committed
690
            s" Toggle-State" rbutton new
bp's avatar
bp committed
691 692 693 694
        0 TN[ 4 typ ]T[ toggle-on$  4 typ$ code-string text!
                        toggle-off$ 4 typ$ code2-string text! ]TN
            s" Toggle-Bit" rbutton new
        cur back with 2fill endwith 6 hartbox new
bp's avatar
bp committed
695 696
        content toggle-on$ typ @ typ$ infocodefield new
        content2 toggle-off$ typ @ typ$ infocodefield new
bp's avatar
bp committed
697
        dup F bind code2-string over F bind code-string
bp's avatar
bp committed
698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
        tooltip-field
        4 vabox new vskip ;
    : null ( -- actor ) 0 flag ['] noop toggle-var new ;
    : make ( -- actor ) 0 flag ['] noop toggle-var new ;
    : assign ( addr1 n1 addr2 n2 -- )  content2 $!  content $! ;
    : dump-tooltip ( -- )
        tooltip-string $@ nip
        IF  .'  TT" ' tooltip-string $@ type .' " '  THEN ;
    : dump ( -- ) ." ^^"
        get 2swap
        typ @
        0 case? IF
            space flag @ 2 .r
            ."  T[ " type ."  ][ ( MINOS ) " type ."  ]T ( MINOS ) "
        ELSE 1 case? IF
            ."  TV[ " type ."  ]T[ ( MINOS ) " type ."  ]TV ( MINOS ) "
        ELSE 2 case? IF
            ."  TN[ " type ."  ]T[ ( MINOS ) " type ."  ]TN ( MINOS ) "
bp's avatar
bp committed
716 717 718 719 720
        ELSE 3 case? IF
	    ."  TS[ " type ."  ][ ( MINOS ) " type ."  ]TS ( MINOS ) "
	ELSE 4 case? IF
	    ."  TB[ " type ."  ]T[ ( MINOS ) " type ."  ]TB ( MINOS ) " 
        ELSE drop THEN THEN THEN THEN THEN
bp's avatar
bp committed
721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750
        dump-tooltip ;
    : get ( -- addr1 n1 addr2 n2 )  content $@ content2 $@ ;
class;

descriptor class index-des
public:
    cell var fstate
how:
    : init ( -- )  super init  fstate on ;
    : edit-field ( -- o )
        item xywh 2drop 1 2 item parent clicked
        s" Flipper" text-label new ;
    : null ( -- o )
        cur box widgets self ?hbox cur +boxmode !
        addcardfile
        dup item self new-link  -1 flipper ;
    : make ( -- o )  item self fstate @ flipper ;
    : dump ( -- o )  ." 0 "
        item self find-linked
        combined with attribs c@ endwith :flip and 0= .
        ." flipper " ;
class;

descriptor class step-des
    cell var hstep
    cell var vstep
how:
    : init 1 hstep ! 1 vstep ! ;
    : edit-field ( -- o )
        ^ F cur bind step
bp's avatar
bp committed
751 752
        get drop 0 0 SN[ ]SN
        s" Hstep:" infotextfield new
bp's avatar
bp committed
753
        dup F bind edit-string
bp's avatar
bp committed
754 755
        get nip  0 0 SN[ ]SN
        s" Vstep:" infotextfield new
bp's avatar
bp committed
756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
        2 habox new 1 hskips ;
    : get  hstep @ vstep @ ;
    : assign ( hstep vstep -- )  vstep ! hstep ! ;
    : null ( -- hstep vstep ) 1 1 ;
    : make ( -- hstep vstep ) hstep @ vstep @ ;
    : dump ( -- ) hstep @ . vstep @ . ;
class;

descriptor class beam-des
how:
    : init ;
    : edit-field ( -- o )
        s" Beamer" text-label new ;
    : null  0 0 ;
    : make  0 0 ;
    : assign ;
    : dump ( -- )  ." :beamer " ;
class;

descriptor class slider-des
    cell var steps
    cell var width
how:
bp's avatar
bp committed
779
    : init #10 steps ! #1 width ! ;
bp's avatar
bp committed
780 781
    : edit-field ( -- o )
        ^ F cur bind slider
bp's avatar
bp committed
782 783
        get drop 0 0 SN[ text@ drop cur slider get nip cur slider assign ]SN
        s" Steps:" infotextfield new
bp's avatar
bp committed
784
        dup F bind edit-string 
bp's avatar
bp committed
785 786
        get nip 0 0 SN[ cur slider get drop text@ drop cur slider assign ]SN
        s" Width:" infotextfield new
bp's avatar
bp committed
787 788 789 790 791 792
        2 habox new 1 hskips ;
    : get ( -- steps width )  steps @ width @ ;
    : assign ( steps width -- )  2dup width ! steps !
        item self 0= IF  2drop  EXIT  THEN
         item self widget with 0 -rot callback assign endwith
        item !resized  item resized ;
bp's avatar
bp committed
793
    : null ( -- actor ) cur pane self 0 #10 1 slider-var new ;
bp's avatar
bp committed
794 795
    : make ( -- actor ) cur pane self 0 get slider-var new ;
    : dump ( -- )
bp's avatar
bp committed
796
        base push decimal ." ^^ 0 #" get swap . ." #" . ;
bp's avatar
bp committed
797 798 799 800 801 802 803
class;

descriptor class scaler-des
    cell var contents
public:
    cell var pos
    early offset!
bp's avatar
bp committed
804 805
    early text*!
    early text/!
bp's avatar
bp committed
806
how:
bp's avatar
bp committed
807
    : init #10 contents ! ;
bp's avatar
bp committed
808
    : h-offset ( -- addr )
bp's avatar
bp committed
809 810 811
	item self hscaler with offset endwith ;
    : text*/ ( -- addr )
	item self hscaler with text*/ endwith ;
bp's avatar
bp committed
812 813 814 815 816 817 818 819 820
    : assign ( n -- ) dup contents !
        item self 0= IF  drop  EXIT  THEN
        item self widget with get endwith nip nip
        over min h-offset @ + swap
        item self widget with callback assign endwith
        item !resized  item resized ;
    : offset! ( n -- )
        item self 0= IF  drop  EXIT  THEN
        h-offset !
bp's avatar
bp committed
821 822 823 824 825 826 827 828 829
	item !resized  item resized ;
    : text*! ( n -- )
	item self 0= IF  drop  EXIT  THEN
	text*/ cell+ !
	item !resized  item resized ;
    : text/! ( n -- )
	item self 0= IF  drop  EXIT  THEN
	text*/ !
	item !resized  item resized ;
bp's avatar
bp committed
830 831
    : edit-field ( -- o )
        ^ F cur bind slider
bp's avatar
bp committed
832 833 834 835 836 837 838 839
        get 0 0 SN[ text@ drop cur slider assign ]SN
        s" Steps:" infotextfield new
        h-offset @ s>d 0 SN[ text@ drop cur slider with offset! endwith ]SN
        s" Offset:" infotextfield new
        text*/ cell+ @ s>d 0 SN[ text@ drop cur slider with text*! endwith ]SN
        s" Scale:" infotextfield new
        text*/ @ s>d 0 SN[ text@ drop cur slider with text/! endwith ]SN
        s" Div:" infotextfield new
bp's avatar
bp committed
840
        4 habox new hskip
bp's avatar
bp committed
841
        dup F bind edit-string ;
bp's avatar
bp committed
842
    : null ( -- actor ) cur pane self pos @ #9 scale-var new ;
bp's avatar
bp committed
843 844 845 846 847 848
    : make ( -- actor ) cur pane self pos @ get scale-var new ;
    : get ( -- n ) contents @ ;
    : dump ( -- ) base push decimal ." ^^ "
        item self hscaler with get nip nip endwith .d
        get .d ;
    : post-dump ( -- )
bp's avatar
bp committed
849 850
	h-offset @ ?dup  IF  space .d ." SC# " THEN
	text*/ 2@ 1 1 d= 0= IF  space text*/ 2@ swap .d .d ." SC*/ " THEN ;
bp's avatar
bp committed
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883
class;

action-des class slider-code
how:
    : null ( -- ) ;
    : make ( -- ) ;
    : init ( -- ) s" " tooltip-string $!  s" ( pos -- ) drop" assign ;
    : dump ( -- ) ." SL[ " get type ."  ]SL ( MINOS ) " dump-tooltip ;
class;

slider-code class scaler-code
how:
    : dump ( -- ) ." SC[ " get type ."  ]SC ( MINOS ) " dump-tooltip ;
class;

descriptors class component-des
    cell var cparam
    cell var cname
how:
    : init  0 super init ;
    : assign ( addr1 u1 addr2 u2 -- )
        cparam $!  cname $! ;
    : dump-class ( -- ) cname $@ type ;
    : dump ( -- )  cr indent @ spaces
        ." ^^ CP[ " cparam $@ type ."  ]CP ( MINOS ) "
        dump-class ."  new "
        name $@ nip IF  ."  ^^bind " dump-name  THEN ;
    : null 0 S[ ]S cname $@ button new dup bind item
        self F bind cur-descs
        all-descs self cur-descs bind next
        cur-descs self F bind all-descs ;
    : make null ;
    : edit-field ( -- o )
bp's avatar
bp committed
884 885
        name $@ 0 ST[ text@ >current-name ]ST
        s" Component"
bp's avatar
bp committed
886
        tableinfotextfield new dup F bind name-string
bp's avatar
bp committed
887 888
        cname $@ 0 ST[ text@ cur-descs with cname $! cname $@ item assign endwith ]ST
        s" Class"
bp's avatar
bp committed
889
        tableinfotextfield new dup F bind edit-string
bp's avatar
bp committed
890 891
        cparam $@ 0 ST[ text@ cur-descs with cparam $! endwith ]ST
        s" Params"
bp's avatar
bp committed
892 893 894 895 896 897 898
        tableinfotextfield new dup F bind code-string
        3 vabox new panel ;
class;

0 descriptors : nil-desc
    nil-desc self nil-desc bind next
    nil-desc self bind all-descs