minos-complex.fs 39.9 KB
Newer Older
1 2 3 4
\ component                                            04mar00py

: get-win ( -- win )  & displays @ object class?
  IF  displays get-win  ELSE  widget dpy get-win  THEN ;
bp's avatar
bp committed
5 6 7 8 9

modal class component
    early open immediate
    early dialog immediate
    early open-app immediate
10
    early menu immediate
11
    early open-win
bp's avatar
bp committed
12 13 14 15 16 17
    method params
    method widget
  how:
    : widget s" Nothing" text-label new ;
    : params   DF[ 0 ]DF s" No Title" ;
    : init ( -- ) ^>^^ assign
bp's avatar
bp committed
18
        widget 1 ^ params 2drop nip super init ;
19
    : open-win ( -- )  self params rot drop
bp's avatar
bp committed
20
        screen self window new  window with  assign show  endwith ;
bp's avatar
bp committed
21
    : make     ( o -- win )
bp's avatar
bp committed
22 23
        new, dup >o params o> rot drop
        screen self window new  window with  assign ^  endwith ;
bp's avatar
bp committed
24 25
    : open,     make  window with  show  endwith ;
    : dialog,   make  get-win
bp's avatar
bp committed
26
        swap window with  set-parent show  endwith ;
bp's avatar
bp committed
27
    : open-app, make  window with  show up@ app ! 1 apprefcnt +! endwith ;
28
    : menu,     ( o -- o ) >o widget o> ;
29
    : open     ( -- )     o@ state @
bp's avatar
bp committed
30
        IF postpone ALiteral postpone open, ELSE open, THEN ;
31
    : dialog     ( -- )     o@ state @
bp's avatar
bp committed
32
        IF postpone ALiteral postpone dialog, ELSE dialog, THEN ;
33
    : open-app     ( -- )     o@ state @
bp's avatar
bp committed
34
        IF postpone ALiteral postpone open-app, ELSE open-app, THEN ;
35
    : menu     ( -- )     ^ state @
bp's avatar
bp committed
36
        IF postpone ALiteral postpone menu, ELSE menu, THEN ;
bp's avatar
bp committed
37 38
class;

39 40 41 42 43 44 45 46 47
: new-component ( o od addr u -- o )
  >r >r  1 swap modal new  r> r>
  screen self window new  window with  assign ^  endwith ;
: open-component    ( o od addr u -- )
  new-component  window with  show  endwith ;
: open-dialog       ( o od addr u -- )
  new-component  get-win
  swap window with  set-parent show  endwith ;
: open-application  ( o od addr u -- )
bp's avatar
bp committed
48
  new-component  window with  show up@ app ! 1 apprefcnt +!  endwith ;
bp's avatar
bp committed
49 50

\ empty menu stub
51

bp's avatar
bp committed
52 53 54 55 56 57 58
component class <menu>
how:
  : params   DF[ 0 ]DF s" No Title" ;
  : widget
        ^^ S[  ]S ( MINOS ) s" --Stub--" menu-entry new 
      #1 vabox new #2 borderbox ;
class;
bp's avatar
bp committed
59 60

\ empty box stub
bp's avatar
bp committed
61

bp's avatar
bp committed
62 63 64 65 66 67 68 69 70 71 72 73
widget class cross
how:
    : hglue  parent self combined with n @ endwith 1 <= IF
        xM 1 *fill  ELSE  0 0  THEN ;
    : vglue  parent self combined with n @ endwith 1 <= IF
        xM 1 *fill  ELSE  0 0  THEN ;
    : draw  parent self combined with n @ endwith 1 > ?EXIT
        xywh defocuscol @ @ dpy box
        xywh 2over p+ 0 dpy line
        x @ y @ h @ + x @ w @ + y @ 0 dpy line ;
class;

bp's avatar
bp committed
74 75 76 77 78 79 80 81 82
menu-window class menu-component
    early open immediate
    early dialog immediate
    early open-app immediate
    method params
    method widget
  how:
    : widget s" Nothing" text-label new ;
    : params   DF[ 0 ]DF s" No Title" ;
bp's avatar
bp committed
83
    : init ( -- )  screen self super init ^>^^
bp's avatar
bp committed
84
        widget 1 ^ params 2>r nip modal new 2r> assign ;
bp's avatar
bp committed
85 86
    : open,     new,  window with  show  endwith ;
    : dialog,   new,  get-win
bp's avatar
bp committed
87
        swap window with  set-parent show  endwith ;
bp's avatar
bp committed
88
    : open-app, new,  window with  show up@ app ! 1 apprefcnt +!  endwith ;
89
    : open     ( -- )     o@ state @
bp's avatar
bp committed
90
        IF postpone ALiteral postpone open, ELSE open, THEN ;
91
    : dialog     ( -- )     o@ state @
bp's avatar
bp committed
92
        IF postpone ALiteral postpone dialog, ELSE dialog, THEN ;
93
    : open-app     ( -- )     o@ state @
bp's avatar
bp committed
94
        IF postpone ALiteral postpone open-app, ELSE open-app, THEN ;
bp's avatar
bp committed
95
class;
96 97 98

\ OpenGL canvas                                        22jun02py

bp's avatar
bp committed
99
also opengl also glconst
100

bp's avatar
bp committed
101
[defined] win32 [IF]
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
        | Create pfd  sizeof PIXELFORMATDESCRIPTOR w, 1 w,
          0 ( PFD_DRAW_TO_WINDOW or ) PFD_DRAW_TO_BITMAP or
          PFD_SUPPORT_OPENGL or \ PFD_SUPPORT_GDI or
          ( PFD_DOUBLEBUFFER or ) ,
          PFD_TYPE_RGBA c,
          &24 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c,
          0 c, 0 c, 0 c, 0 c, &32 c, 0 c, 0 c,
          PFD_MAIN_PLANE c, 0 c, 0 , 0 , 0 ,
        | Create bih sizeof BITMAPINFOHEADER ,
          0 , 0 , 1 w, &24 w, BI_RGB , 0 , 0 , 0 , 0 , 0 ,
[THEN]

\ OpenGL canvas                                        15aug99py

0 Value canvas-mode

glue class glcanvas
public: defer drawer            method render
        cell var visinfo        cell var pixmap
        cell var ctx            cell var glxpm
        cell var glxwin         cell var rendered
        window-stub ptr stub    cell var shown
bp's avatar
bp committed
124
[defined] win32 [IF]
125
        cell var oldbm          cell var dibptr
bp's avatar
bp committed
126
[THEN] [defined] x11 [IF]
127 128 129 130 131 132
        cell var cmap
[THEN]
        widget ptr outer

\ OpenGL canvas                                        08jul00py
how:
bp's avatar
bp committed
133
[defined] x11 [IF]
134 135 136 137 138 139 140
        | Create attrib GLX_DOUBLEBUFFER ,
                        GLX_RGBA ,
                        GLX_RED_SIZE   ,   1 ,
                        GLX_GREEN_SIZE ,   1 ,
                        GLX_BLUE_SIZE  ,   1 ,
                        GLX_DEPTH_SIZE ,  $10 ,  0 ,
        : init  ( exec actor w w+ h h+ -- )
bp's avatar
bp committed
141
          super init  >callback  IS drawer  ^^ bind outer ;
142 143 144 145 146 147 148 149
        : dpy!  super dpy!
          dpy xrc with dpy @ screen @ endwith
          attrib canvas-mode 1 and cells +
          glXChooseVisual visinfo !
          dpy xrc dpy @ visinfo @ 0 1 glXCreateContext ctx ! ;

\ OpenGL canvas                                        09dec07py
        : destroy-pixmap ( -- ) dpy xrc dpy @
150
          glxwin @ ?dup  IF  over swap XDestroyWindow drop
151 152 153
                             glxwin off  THEN
          glxpm  @ ?dup  IF  over swap glXDestroyGLXPixmap
                             glxpm  off  THEN
bp's avatar
bp committed
154
          pixmap @ ?dup  IF  over swap XFreePixmap
155
                             pixmap off  THEN
156
          cmap   @ ?dup  IF  over swap XFreeColormap
157 158 159 160 161 162 163 164 165 166 167
                             cmap   off  THEN  drop ;
        : set-context ( -- )
          dpy xrc dpy @ glxpm @ glxwin @ or
          ctx @ glXMakeCurrent drop ;
        : dpyscreen ( -- dpy screen )
          dpy xrc dpy @ visinfo @ XVisualInfo screen @ ;

\ OpenGL canvas                                        09jan00py
        : new-window   xswa sizeof XSetWindowAttributes erase
          AllocNone visinfo @ XVisualInfo visual @
          dup dpy xrc vis @ <> canvas-mode 4 and or
bp's avatar
bp committed
168
          IF    dpy drawable drop 2swap swap XCreateColormap dup cmap !
169 170 171 172 173
          ELSE  2drop dpy xrc cmap @  THEN
              xswa XSetWindowAttributes colormap !
          dpyscreen BlackPixel dup
              xswa XSetWindowAttributes border_pixel !
              xswa XSetWindowAttributes background_pixel !
174

bp's avatar
bp committed
175
          event-mask  xswa XSetWindowAttributes event_mask !
176

bp's avatar
bp committed
177 178 179 180 181
          dpy xrc dpy @ dpy get-win
          x @ y @ w @ 1 max h @ 1 max
          0           visinfo @ XVisualInfo depth  @
          InputOutput visinfo @ XVisualInfo visual @
          glxvals xswa XCreateWindow
182 183 184 185 186 187 188
          self over window-stub new bind stub ;

\ OpenGL canvas                                        09dec07py

        : new-pixmap ( -- )  glxwin @ ?EXIT  glxpm @ ?EXIT
          dpy xwin @ dpy get-win = canvas-mode 2 and 0= and  IF
              new-window glxwin ! rendered off  EXIT THEN
bp's avatar
bp committed
189
          dpy xrc dpy @ dpy get-win
bp's avatar
bp committed
190
          w @ 4 max 3 + -4 and h @ 4 max
191
          visinfo @ XVisualInfo depth @
bp's avatar
bp committed
192
          XCreatePixmap dup pixmap !
193 194 195 196 197 198 199 200 201 202
          dpy xrc dpy @ visinfo @ rot glxCreateGLXPixmap
          glxpm ! rendered off ;
        : show ( -- )  shown @ shown on ?EXIT
          new-pixmap stub self 0= ?EXIT
          xywh stub resize stub show ;
        : hide ( -- )  shown @ shown off 0= ?EXIT
          stub self 0= ?EXIT  stub hide ;
[THEN]

\ OpenGL canvas                                        23sep99py
bp's avatar
bp committed
203
[defined] win32 [IF]
204 205 206 207 208 209 210 211 212 213 214 215 216
        : set-context ctx @ pixmap @ wglMakeCurrent ?err ;
        : add-dib-section  h @ 1 max w @ 1 max  bih cell+ 2!
          0 0 0 DIB_RGB_COLORS bih
          pixmap @ CreateDIBSection dup ?err glxpm !
          glxpm @ pixmap @ SelectObject dup ?err oldbm !
          pfd dup pixmap @ ChoosePixelFormat dup ?err
          pixmap @ SetPixelFormat ?err ;
        : new-pixmap ( -- )  0 0 wglMakeCurrent drop
          screen xrc dc @ CreateCompatibleDC dup ?err pixmap !
          add-dib-section
          pixmap @ wglCreateContext dup ?err ctx !
          rendered off ;
        : init  ( exec actor w w+ h h+ -- )
bp's avatar
bp committed
217
          super init  >callback  IS drawer  ^^ bind outer ;
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232

\ OpenGL canvas                                        01nov06py

        : destroy-pixmap ( -- )
          ctx    @ ?dup  IF  0 0 wglMakeCurrent drop
                             wglDeleteContext drop ctx off THEN
          pixmap @ ?dup  IF  DeleteObject drop pixmap off THEN
          glxpm  @ ?dup  IF  DeleteObject drop glxpm  off THEN ;

[THEN]

\ OpenGL canvas                                        09dec07py

        : resize ( x y w h -- )
          super resize rendered off
bp's avatar
bp committed
233
[defined] win32 [IF]
234 235 236 237 238 239
          oldbm @ pixmap @ SelectObject ?err
          glxpm  @ ?dup  IF  DeleteObject drop glxpm  off THEN
          add-dib-section
[ELSE]    glxpm  @   IF  destroy-pixmap  THEN  new-pixmap
          stub self  IF  xywh stub resize  stub show  THEN
[THEN]  ;
bp's avatar
bp committed
240
        : dispose destroy-pixmap  [defined] x11 [IF]
241 242 243 244 245 246 247 248 249 250
          ctx @ ?dup  IF
              dpy xrc dpy @ swap glXDestroyContext  THEN
[THEN]    stub self IF  stub dispose  THEN  glFlush
          super dispose ;

\ OpenGL canvas                                        08dec07py

        : render ( -- ) \ ." render "
          pixmap @ glxwin @ or 0= IF  new-pixmap  THEN
          set-context ^ drawer  glFlush
bp's avatar
bp committed
251
[defined] x11 [IF]
252 253 254 255 256 257 258 259
          glxpm @
          IF  dpy xrc dpy @ glxpm @ glXSwapBuffers  THEN
[THEN]    rendered on ;

\ OpenGL canvas                                        22oct06py

        : draw ( -- )
          rendered @ 0=  IF  render  THEN
bp's avatar
bp committed
260
[defined] x11 [IF]   pixmap @
261 262 263 264 265 266
          IF    0 0 xywh 2swap pixmap @ dpy image
          ELSE  glxwin @
            IF  dpy xrc dpy @ glxwin @ glXSwapBuffers
                rendered off  THEN
          THEN
[THEN]
bp's avatar
bp committed
267
[defined] x11_ximage [IF]   0 0 xywh 2swap 0 sp@ >r 0 sp@ r>
268 269
          pixmap @ dpy xrc dpy @ XMesaFindBuffer
          XMesaGetBackBuffer drop nip dpy ximage  [THEN]
bp's avatar
bp committed
270
[defined] win32 [IF]   0 0 xywh 2swap pixmap @ dpy image  [THEN]
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
        ;

\ OpenGL canvas                                        04aug05py

        boxchar :: clicked ( x y b n -- )
        boxchar :: keyed ( key sh -- )
        : moved ( x y -- ) 2drop  stub self
          IF    mouse_cursor stub set-cursor  ^ stub set-rect
          ELSE  mouse_cursor dpy  set-cursor  ^ dpy  set-rect
          THEN  callback enter ;
        boxchar :: leave ( -- )
class;

\ canvas                                               11jul99py

previous previous

288 289
: GL[  postpone [: glcanvas postpone with ;        immediate
: ]GL  glcanvas postpone endwith  postpone ;] ;    immediate
bp's avatar
bp committed
290

291 292
: CV[  postpone [: canvas postpone with ;        immediate
: ]CV  canvas postpone endwith  postpone ;] ;    immediate
293 294 295 296 297

\ helper words for Theseus                             21sep07py

: T"   postpone S" ;                             immediate

bp's avatar
bp committed
298 299 300 301 302 303
[defined] VFXFORTH [IF]
    Variable ^^bind-string
    : ^^bind  postpone dup  postpone bind2 ;     immediate
[ELSE]
    : ^^bind  postpone dup  postpone bind ;      immediate restrict
[THEN]
bp's avatar
bp committed
304 305


306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
\ IO-Window                                            26oct99py

: scan8 ( addr u -- addr u' )  2dup bounds
  ?DO  I c@ $80 and IF  drop I over - LEAVE  THEN  LOOP ;
: scan16 ( addr u -- addr' u' )  bounds  scratch 0 2swap
  ?DO  I c@ $80 and 0= ?LEAVE
       2dup + I c@ $7F and 8 << I 1+ c@ or
       swap w! 2+  2 +LOOP ;

\ IO-Window                                            12mar00py

0 Value do-scroll

boxchar class terminal
public: cell var cols           cell var rows
        cell var color          cell var cursor#
        cell var pos            cell var selw
        cell var keys           cell var start
        cell var scrolls        cell var typebuf
        cell var maxrows        cell var minrows
        cell var addr           cell var u
        1 var resize!           1 var flush!
        2 var text-color
        cell var sizew          font ptr fnt16
        & dpy viewport asptr vdpy

\ IO-Window                                            24oct99py

        method type             method page
        method emit             method flush
        method decode           method clrline
        method cr               method c
        method atxy?            method drawcur
        method at?              method at
        method curoff           method curon
        method key?             method key
        method 'start           method 'line
        method scrollup         method scrollback
        method paste-selection
        early showtext          early curpos
        early .text

\ IO-Window                                            06feb00py

how:    6 colors focuscol !     1 colors defocuscol !
        : assign ( w h -- )  1 max rows ! 1 max cols !
          rows @ maxrows !  rows @ minrows !
          typebuf  HandleOff
          start    HandleOff
          cols @ cell+ typebuf Handle!  typebuf @ off
          rows @ 1+ cols @ * start 2dup Handle! @ swap bl fill
          1 selw !  dpy self IF  resized  THEN ;

\ IO-Window                                            05jan07py
        : 'start ( -- addr ) start @
          scrolls @ cols @ * + ;
        : 'line  ( n -- addr u )
363
          scrolls @ cols @ * dup >r + rows @ cols @ * modf r> -
364
          'start + cols @ -trailing ;
bp's avatar
bp committed
365
        : !resized  s" n" !textwh
366 367 368 369 370 371 372 373 374 375 376 377
          4 dpy xrc font@ bind fnt16 ;
        : !tile  0 scrolls @ texth @ * negate dpy txy! ;
        : focus    focuscol   @ @ dup 8 >> swap $FF and 8 << or
                                  color !  drawcur super focus ;
        : defocus  defocuscol @ @ color !  drawcur ;
        : dpy! ( dpy -- )  widget :: dpy!
          fnt   self 0= IF  1 dpy xrc font@ font!       THEN
          fnt16 self 0= IF  4 dpy xrc font@ bind fnt16  THEN ;

\ mixed font output                                    24oct99py

        : .texts ( addr u x y dpy -- )
378
          fnt16 self 0= IF  fnt draw  EXIT  THEN  { x y dpy }
379 380
          BEGIN  dup  WHILE  2dup scan8 dup
                 IF    tuck x y dpy fnt draw
bp's avatar
bp committed
381
                       dup textwh @ * x + to x safe/string
382 383 384
                 ELSE  2drop  THEN
                 2dup scan16 dup
                 IF    tuck x y dpy fnt16 draw
bp's avatar
bp committed
385
                       dup textwh @ * x + to x safe/string
386
                 ELSE  2drop  THEN  REPEAT  2drop ;
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401

\ mixed font output                                    16jan05py

        : font-color! ( c dpy -- )
          over fnt color !  displays with  set-color  endwith ;
        : display-texts ( x y dpy -- )
          >r text-color @ r@ font-color!
          addr @ u @ 2swap r> .texts ;
        : .text ( addr u x y c -- )
          text-color ! 2swap u ! addr !
          ^ ['] display-texts dpy drawer ;

\ mixed font output                                    05may07py

        : expand16 ( -- )  maxascii $80 = IF
402
             pos @ 'line drop
403
             dup 1+ xchar- tuck - negate pos +!
404 405
             dup selw @ + xchar- xchar+ swap - selw !
             EXIT
406 407 408 409 410 411 412 413 414 415 416 417 418 419
          THEN  fnt16 self 0= ?EXIT
          pos @ 1- 0max 'line drop c@ $80 and
          IF  -1 pos +!  1 selw +!  THEN
          pos @ selw @ 1- + 0max 'line drop c@ $80 and
          IF  1 selw +!  THEN ;
        : csize ( s i -- size )
          dup >r - 0max r> 'line rot 2dup swap - 0max >r
          min x-width r> +
          textwh @ * ;

\ IO-Window                                            20oct06py
        : drawcur  dpy self 0= ?EXIT  !tile  expand16
          cursor# @  IF  6 colors @  ELSE  color @  THEN
          pos @ typebuf @ @ +
420
          dup selw @ + 2dup min -rot max { color s e }
421 422 423 424 425 426 427
          x @ y @ cols @ rows @ * 0
          ?DO  s I - cols @ u<  e I - cols @ u< or
               I s e within or
               IF over s I csize dup >r + over r>
                  w @ e I csize min swap - 1 max
                  texth @ color dpy box
                  I 'line e I - 0max min s I - 0max
bp's avatar
bp committed
428
                  safe/string  2over swap s I csize +
429 430
                  swap color 8 >> .text
               THEN  texth @ + cols @ +LOOP
431
          2drop ;
432 433 434 435 436

\ IO-Window                                            16jun02py

        : draw-io ( x y dpyo -- )
          dup displays with clipy endwith
437
          over + { dpyo sclip eclip }
438 439 440 441 442 443 444
          cols @ rows @ * 0
          ?DO  dup sclip eclip within
               IF  2dup w @ texth @
                   6 colors @ dpyo displays with box endwith
                   I 'line 2over 6 colors @ 8 >>
                   dpyo font-color!
                   dpyo .texts
445
               THEN  texth @ + cols @ +LOOP  2drop ;
446 447 448 449 450 451 452 453 454 455 456 457 458
        : draw ( -- )  !tile
          x @ y @ ^ ['] draw-io dpy drawer
          drawcur  0 0 dpy txy! ;

\ IO-Window                                            12mar00py

        : resize-it2 ( -- )
          0 resize! c!  sizew off  parent resized  show-you ;
        : resize-it ( -- )
          vdpy sw @ cols @ textwh @ * min sizew !
          parent resized  dpy set-hints
          ['] resize-it2 ^ /step @ after dpy schedule ;
        : screen-resize
459
          start rows @ $20 + $-20 and
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
          cols @ * SetHandleSize
          resize! c@ ?EXIT  1 resize! c!
          ['] resize-it ^ /step @ after dpy schedule ;

        : xinc ( -- o inc ) sizew @ textwh @ ;
        : yinc ( -- o inc ) 0       texth @ ;

\ IO-Window                                            12mar00py

        : redraw-it ( -- )  0 resize! c!  draw ;
        : screen-redraw
          resize! c@ ?EXIT  1 resize! c!
          ['] redraw-it ^ /step @ after dpy schedule ;

\ IO-Window                                            12mar00py
        : scrollup ( -- )  rows @ maxrows @ <
          IF  1 rows +!   screen-resize
              cols @ rows @ 1- * 'line drop cols @ bl fill
              EXIT  THEN
479
          scrolls @ 1+ rows @ modf scrolls !
480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
          cols @ dup negate pos +!
          cols @ rows @ 1- * 'line drop swap bl fill  do-scroll
          IF    x @ y @ texth @ dup >r +  dpy transback
                w @ h @ r> - x @ y @
                dpy get-win dpy image  !tile
                x @ y @ texth @ rows @ 1- * +
                w @ texth @ 6 colors @ dpy box
                dpy >exposed  0 0 dpy txy!
          ELSE  screen-redraw  THEN ;
        : scrollback ( n -- ) rows @ max maxrows ! ;

\ IO-Window                                            16jan05py
        : showtext ( addr u1 u2 -- )
          resize! c@ IF  drop 2drop  EXIT  THEN
          !tile drop cols @ >r  x @ y @
          at? drop 0 swap texth @ * p+
          2dup textwh 2@ r> * swap 6 colors @ dpy box
497
          pos @ at? nip - 'line 2swap 6 colors @ 8 >> .text 2drop ;
498 499 500 501 502 503 504 505 506 507 508 509
        : linetype ( addr u -- )
          tuck pos @ 'line drop swap 2dup -trailing >r drop move
          >r pos @ r@ + cols @ rows @ * >=
          IF  scrollup  THEN
          pos @ 'line drop r> r> over >r showtext  r> pos +! ;
        : vglue  rows @ texth @ *  0 ;
        : hglue  cols @ textwh @ *  0 ;
        : ?flush ( -- ) flush! c@ ?EXIT  1 flush! c!
          ['] flush ^ /step @ after dpy schedule ;

\ IO-Window                                            06jan05py
        : win-type  ( addr len -- )  cols @ >r
510
          BEGIN  dup pos @ r@ modf r@ - + dup 0>=  WHILE
511 512 513 514 515 516 517 518 519 520 521
                 tuck - >r over r@ + swap rot r> linetype REPEAT
          drop linetype rdrop  ;
        : type  ( addr len -- )  typebuf @ @ over + cols @ >=
          IF   flush curoff win-type curon
          ELSE ?flush tuck typebuf @ @+ + swap move typebuf @ +!
          THEN ;
        : emit  ( char -- )  char$ type ;
        : flush ( -- )  0 flush! c!  typebuf @ @
          IF  typebuf @ @+ swap
              curoff typebuf @ off  win-type  curon  THEN ;
        : moved ( x y -- )  2drop  ^ dpy set-rect
bp's avatar
bp committed
522 523
[defined] x11 [IF]            XC_xterm   [THEN]
[defined] win32 [IF]          IDC_IBEAM  [THEN]  dpy set-cursor  ;
524 525 526 527 528 529 530 531 532

\ IO-Window                                            12mar00py
        : page  ( -- )  flush curoff  pos off  typebuf @ off
          scrolls off  minrows @ rows !  screen-resize
          'start cols @ rows @ * bl fill  curon draw ;
        : at ( r c -- )  flush 0max cols @ 1- min
          swap 0max rows @ 1- min
          cols @ * + curoff pos ! curon ;
        : at? ( -- r c )
533
          pos @ typebuf @ @ + cols @ /modf swap ;
534 535 536 537 538 539 540 541 542 543 544 545 546 547
        : show-you ( -- ) dpy self 0= ?EXIT
          at? textwh 2@ rot * -rot * x @ y @ p+ dpy show-me ;
        : ?sel-scroll  ( c r -- c r )
          over textwh @ * over texth @ *
          x @ y @ p+ dpy scroll ;
        : curpos ( -- x y )
          at? textwh @ * swap 1+ texth @ * ;

\ IO-Window                                            24oct99py

        : at-sel ( r c -- )
          0max cols @ 1- min
          swap 0max rows @ 1- min  ?sel-scroll
          cols @ * + pos @ - cursor# @ pos @ selw @
548
          { s1 c# p s }
549 550 551 552 553 554 555 556
          s s1 xor 0<
          IF  1 cursor# ! drawcur      p       s1      0
          ELSE  s1 0max s 0max <  IF p s1 +  s s1 -  1  ELSE
                s1 0max s 0max >  IF p s +   s1 s -  0  ELSE
                s1 0min s 0min <  IF p s1 +  s s1 -  0  ELSE
                s1 0min s 0min >  IF p s +   s1 s -  1  ELSE
                p 0 1  THEN THEN THEN THEN
          THEN  cursor# ! selw ! pos ! drawcur
557
          c# cursor# ! p pos ! s1 selw ! ;
558 559

\ IO-Window                                            30dec99py
560
        : clrline   flush  curoff pos @ dup cols @ modf - pos !
561 562 563 564 565 566 567 568 569 570
          pos @ 'line drop cols @
          2dup -trailing >r drop 2dup bl fill
          r> showtext curon ;
        : curon  ( -- )  -1 cursor# +!  cursor# @ 0> ?EXIT
          1 selw ! drawcur show-you  cursor# off ;
        : curoff ( -- )  cursor# @  1 cursor# +!  0> ?EXIT
          drawcur 0 selw !  1 cursor# ! ;
        : c  ( n -- )  flush  curoff  pos @ + 0max  pos !
          BEGIN pos @ cols @ rows @ * >= WHILE  scrollup  REPEAT
          curon ;
571
        : cr  ( -- ) flush cols @ pos @ over modf - c
572 573 574 575 576 577
          resize! c@ ?EXIT show-you ;
        : curup    cols @ negate c ;
        : curdown  cols @        c ;

\ IO-Window                                            09mar99py
        : selecting ( -- )  flush  textwh 2@ swap
578
          DOPRESS  x @ y @ p- 2swap swap >r /f swap r> /f at-sel ;
bp's avatar
bp committed
579
        : (dpy  [defined] x11 [IF]    dpy get-win  dpy xrc dpy @
580 581 582 583 584
          [ELSE] 0 0 [THEN] ;
        : mark-selection ( x y -- )  defocus  at? >r >r
          swap at pos @ >r selecting
          -select selw @ pos @ + r>
          2dup max -rot min  0 -rot
585
          ?DO  drop cols @ I over modf -
586 587 588 589 590 591 592 593 594
               I 'line ( drop over -trailing ) I' I - min  tuck
               +select  over I' I - min  <> swap  +LOOP
          IF  s" " +select  THEN  (dpy !select
          curoff  r> r> at focus  curon ;
        : paste-selection ( addr u -- )
          bounds ?DO  I xc@+ 0 keyed pause  I - +LOOP ;

\ IO-Window                                            21aug99py

bp's avatar
bp committed
595
        : copyline  >r >r at? drop cols @ * 'line
596 597
          r@ swap 4 pick min dup 3 pin move
          r> over r> min ;
598
        : >atxy  ( msap xy -- msap )  at? >r >r $100 /modf swap
599
          2dup at r> rot <>
bp's avatar
bp committed
600
          IF  >r copyline r> rdrop over >r  THEN  r>
601 602 603 604 605 606
          - + dup 0min dup negate c - 2 pick over -
          0min dup c + ;

\ IO-Window                                            07jun03py
        : keyed ( key state -- )
          over shift-keys?  IF  2drop  EXIT  THEN
bp's avatar
bp committed
607
          BEGIN  keys @ @ $1F >=  WHILE  pause  REPEAT $18 lshift or
608 609 610 611 612
          keys @ dup @ 1+ $1F min dup keys @ ! cells + ! ;
        boxchar :: handle-key?
        : key?  ( -- flag )
          keys @ @ 0= IF  pause  THEN  keys @ @ 0> ;
        : getkey ( -- key )  keys @ @
613
          IF    keys @ cell+ @  keys @ 8 + dup cell- $78 move
bp's avatar
bp committed
614
                -1 keys @ +! dup $18 rshift kbshift ! $FFFFFF and
615 616 617
          ELSE  0  THEN ;
        : key   ( -- key )  flush  1 cursor# ! curon
          BEGIN  key?  0= WHILE
bp's avatar
bp committed
618 619
                  dpy xrc fid [defined] VFXFORTH [IF] #1 [ELSE] #50 [THEN] idle
          REPEAT
620 621 622 623 624
          getkey curoff ;

\ IO-Window                                            06jan05py

        : decode ( m s addr pos char -- m s addr pos flag )
bp's avatar
bp committed
625
          kbshift @ $40 and  IF  drop 0 EXIT  THEN
bp's avatar
bp committed
626
[defined] (Ftast [IF]  dup $FFBE $FFCA within
627 628 629 630 631 632 633 634 635
          IF  $FFBE - cells (Ftast + -rot >r >r -rot >r >r
              perform r> r> r> r> prompt cr save-cursor
              over 3 pick type row over at 0 EXIT THEN
 [THEN]   $FF51 case?  IF  ctrl B  THEN
          $FF52 case?  IF  ctrl P  THEN
          $FF53 case?  IF  ctrl F  THEN
          $FF54 case?  IF  ctrl N  THEN
          dup $007F = IF  drop ctrl D  THEN
          dup $FF00 and $FF00 =  IF  drop 0 EXIT  THEN
636
[defined] VFXFORTH [IF] PCdecode  [ELSE]
637
[defined] utf-8 [IF]  xdecode [ELSE] PCdecode [THEN] [THEN] ;
638 639 640 641 642

\ IO-Window                                            01jan05py

        : init ( w h -- )  $80 keys Handle!  keys @ off
        ^ CK[ 2swap y @ -
643
              texth @ /f swap x @ - textwh @ /f swap 2swap
644 645 646
              1 and  IF  drop mark-selection  EXIT  THEN
              1 and 0=  IF  2drop (dpy @select paste-selection
                            EXIT  THEN
bp's avatar
bp committed
647
              8 << or kbshift @ $40 or keyed ]CK >callback
648
          assign  defocuscol @ @ color ! ;
bp's avatar
bp committed
649
        : close  #cr 0 keyed S" bye"  bounds ?DO  i c@ 0 keyed  LOOP ;
650 651 652 653
        : dispose start HandleOff  keys HandleOff
          typebuf HandleOff  ^ dpy cleanup  super dispose ;
class;

654
[defined] VFXFORTH [IF]
655
    Defer WinI/O
656 657 658
    Defer terminal-menu             ' noop IS terminal-menu
    2Variable map-size              80 24 map-size 2!
    2Variable map-pos
659 660
    #1000 Value MaxScroll
    terminal ptr term
661 662 663 664
    hbox ptr term-menu
    rule ptr term-last

    : openw  screen self menu-window new
665
        menu-window with
bp's avatar
bp committed
666 667
          term-w set-icon
          0 1 *fill 0 1 *fil rule new dup F bind term-last
668 669 670
        1 hbox new vfixbox dup F bind term-menu 1 vbox new
          1 1 viewport new
              D[ map-size 2@ terminal new dup F bind term ]D
671
        s" VFX Forth Dialog" assign
672 673 674 675 676
        terminal-menu
        map-size 2@ geometry
        map-pos 2@ d0= 0= IF  map-pos 2@ repos  THEN
        show endwith
        map-size 2@ c/cols ! c/line !
677
    MaxScroll term scrollback WinI/O ;
678
[ELSE]
679 680
\ Window IO words                                      10apr04py
terminal uptr term      Forward openw
bp's avatar
bp committed
681
[THEN]
682 683 684 685 686 687 688 689 690 691 692 693 694 695
| : term?  term self 0= IF  openw  THEN ;
: WINtype  ( addr l -- )  term? term type pause ;
: WINemit  ( char -- )    term? term emit ;
: WINflush ( -- )         term? term flush ;
: WINcr    ( -- )         term? term cr pause ;
: WINpage  ( -- )         term? term page ;
: WINat    ( rol col -- ) term? term at  ;
: WINat?   ( -- row col ) term? term at? ;
: WINform  ( -- rs cs )   term? term rows @ term cols @ ;
: WINcuron    ( -- )      term? term curon ;
: WINcuroff   ( -- )      term? term curoff ;
: WINcurleft  ( -- )      term? -1 term c ;
: WINcurrite  ( -- )      term?  1 term c ;
: WINclrline  ( -- )      term? term clrline ;
bp's avatar
bp committed
696 697 698 699

: WINkey? ( -- flag )  term? term key? ;
: WINkey  ( -- key )   term? term key ;
: WINdecode            term? term decode ;
bp's avatar
bp committed
700 701 702
[defined] VFXFORTH [IF]
    ' WINdecode IS decode
[THEN]
703 704

\ Window IO words                                      05jan05py
705
[defined] VFXFORTH [IF]
706 707
    : >out  WINat? out ! op-line# ! ;
    : WINsetpos' ( x y mode sid -- ior ) 2drop swap WINat 0 >out ;
708 709 710 711
    : WINgetpos' ( mode sid -- x y ior ) 2drop WINat? swap 0 ;
    : WINflush' ( sid -- ior ) drop WINflush 0 ;
    : WINkey' drop WINkey ;
    : WINkey?' drop WINkey? ;
712 713 714 715 716 717
    : WINemit' drop WINemit >out ;
    : WINtype' drop WINtype >out ;
    : WINcr' drop WINcr >out ;
\    : WINlf' drop WINclrline >out ;
    : WINpage' drop WINpage >out ;
    : WINcurleft' drop WINcurleft >out ;
718
    : WINemit?' drop true ;
719
    : WINaccept' drop PCaccept ;
720 721 722 723 724 725 726 727 728
    Create WINio-table
    ' .s , \ open
    ' false , \ close
    ' drop , \ read
    ' drop , \ write
    ' WINkey' ,
    ' WINkey?' ,
    ' WINkey' ,
    ' WINkey?' ,
729
    ' WINaccept' , \ accept
730 731 732 733 734 735 736 737 738 739 740 741 742 743
    ' WINemit' ,
    ' WINemit?' ,
    ' WINtype' ,
    ' WINcr' ,
    ' WINcr' , \ line feed
    ' WINpage' , \ form feed
    ' WINcurleft' ,
    ' noop ,
    ' WINsetpos' ,
    ' WINgetpos' ,
    ' 2drop , \ ioctl
    ' WINflush' ,
    ' noop , \ readex
    Create WINio-sid 0 , WINio-table , 0 ,
744
    : WINdisplay ( -- ) WINio-sid dup op-handle ! to PauseConsole ;
745
    : WINkeyboard ( -- ) WINio-sid ip-handle ! ;
746
    :noname  WINdisplay  WINkeyboard ; IS WinI/O
747
[ELSE]
748 749 750 751 752
Output: WINdisplay
        WINemit true WINcr WINtype PCdel WINpage
        WINat WINat? WINform  noop noop WINflush
        WINcuron WINcuroff WINcurleft WINcurrite WINclrline [

bp's avatar
bp committed
753
[defined] xaccept [IF]
754
        Input:  WINkeyboard
bp's avatar
bp committed
755
        WINkey WINkey? WINdecode xaccept false [
756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
[ELSE]  Input:  WINkeyboard
        WINkey WINkey? WINdecode PCaccept false [  [THEN]
: WINi/o  WINdisplay  WINkeyboard ;

\ openw                                                10apr04py

2Variable map-size              PCform swap map-size 2!
2Variable map-pos
&1000 Value MaxScroll
hbox uptr term-menu             rule uptr term-last
Defer terminal-menu             ' noop IS terminal-menu

minos

\ openw                                                21jun05py

: openw ( -- )  screen self menu-window new
  menu-window with
      term-w set-icon
      0 1 *fill 0 1 *fil rule new dup F bind term-last
   1 hbox new vfixbox dup F bind term-menu 1 vbox new
777 778
      1 1 viewport new
          D[ map-size 2@ terminal new dup F bind term ]D
779 780
      s" bigFORTH Dialog" assign
      terminal-menu
781 782
      map-size 2@ geometry
      map-pos 2@ d0= 0= IF  map-pos 2@ repos  THEN
bp's avatar
bp committed
783
      sync show endwith
784
  MaxScroll term scrollback
785
  event-task' task's term dup @
786 787
  0= IF  term self swap !  ELSE  drop  THEN
  ['] WINi/o IS standardi/o  WINi/o ;
788
[THEN]
789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813

\ terminal menu operations                             10apr04py

: add-menu ( menu -- )  term-last self term-menu add ;
: add-help ( menu -- )  'nil           term-menu add ;
: hide-menu ( -- )  term-menu parent self
  vbox with -flip endwith ;
: show-menu ( -- )  term-menu parent self
  vbox with +flip endwith ;

: send-string ( addr u -- )
  bounds ?DO  i c@ 0 displays keyed  LOOP ;

\ terminal menu operations                             10apr04py

actor class key-actor
public: cell var string
how:    : init ( o addr u -- )  string $!  super init ;
        : fetch ( -- n ) 0 ;
        : store ( n -- ) string $@
          ['] send-string called send drop ;
class;

: key"  state @
  IF    postpone ^  postpone S" key-actor postpone new
814
  ELSE  ^ '"' parse key-actor new  THEN ;        immediate
815 816 817

\ : term-dpy  term dpy dpy self ;

bp's avatar
bp committed
818 819 820 821 822 823 824 825 826 827 828
\ file widget                                          10apr04py
DOS also
lbutton class file-widget
public: cell var size           cell var time
        cell var attr           cell var wsize
        cell var wtime          cell var wdate
how:    \ 6 colors defocuscol !
        : dispose 0 bind callback  super dispose ;
        : assign ( size time attr addr len -- )  base push
          super assign attr ! time ! size ! ;
        : !resized super !resized  decimal
bp's avatar
bp committed
829
          size @ 0 <<# #s #> 0 textsize drop wsize ! #>>
bp's avatar
bp committed
830 831
          S" 00may99"       0 textsize drop wdate !
          S" 00:00:00"      0 textsize drop wtime ! ;
bp's avatar
bp committed
832 833
[defined] x11 [IF]   : dir@ attr @ $C >> ;             [THEN]
[defined] win32 [IF] : dir@ attr @ $10 and 0<> 4 and ; [THEN]
bp's avatar
bp committed
834 835 836 837 838 839 840 841 842 843

\ file widget                                          10apr04py
        : draw ( -- )  base push decimal  push? 1 and >r
          xywh color @ dpy box
          r@ IF  shadow swap xS xywh drawshadow  THEN
          text $@
          xywh nip texth @ - 2/ +  xS 1+ 0 p+
          r@ r@ p+  x @ xS + r@ + y @ xS + r@ +
          dir@ r> 4 << or ficons icon-pixmap with draw-at
          w @ endwith xS + xM color @ 8 >>
844
          { iw m cc }  dpy mask
bp's avatar
bp committed
845 846 847 848
          2swap 2over iw 0 p+ cc .text
          w @ wdate @ - 6 - 0 p+
          time @ >date 2over  cc .text
          m wtime @ + 0 p-   time @ >time 2over cc .text
bp's avatar
bp committed
849 850
          m wsize @ + 0 p- size @ 0 <<# #s #>
          2swap cc .text #>> ;
bp's avatar
bp committed
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869

\ file widget                                          10apr04py
        : hglue ( -- glue )  super hglue xM 3 *
          wdate @ wtime @ wsize @ + + +
          dir@ ficons >o icon-pixmap w @ o> + 8 + 0 p+ ;
        : vglue ( -- glue )  super vglue swap
          dir@ ficons >o icon-pixmap h @ o> xS 2* + 1+
          max swap ;
        : clicked  ( click -- )
          dup 0= IF  2drop 2drop  EXIT  THEN
          dup 2/ 1 > >r >released ( cc )
          0= IF  rdrop  EXIT THEN
          0 text $@ callback store
          r> IF  #cr 0 dpy dpy keyed  THEN ;
        : keyed ( key sh -- )  drop bl =
          IF  xywh 2drop  1 2 clicked  THEN ;
class;

\ file listbox                                         10apr04py
bp's avatar
bp committed
870 871
[defined] x11 [IF]     : dir? @attr $C >> 4 = ;        [THEN]
[defined] win32 [IF]   : dir? @attr $10 and 0<> ;      [THEN]
bp's avatar
bp committed
872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888
component class file-listbox
public: actor ptr file          actor ptr path
        cell var file<=         early name<=
        early date<=            early length<=
how:    : read-files ( addr attr -- w1 .. wn n )
          fsfirst 0 >r
          BEGIN  pause  0=  WHILE  dir? 0=
                 IF  \ cr ." file " dtaname >file type
                     file self
                     @length @time @attr
                     dtaname >len file-widget new
                     r> 1+ >r  THEN  fsnext
          REPEAT  r> ;

\ file listbox                                         10apr04py

        : read-dir  ( addr attr -- w1 .. wn n )
bp's avatar
bp committed
889
          over >len '/' -scan + dup push '*' swap w!
bp's avatar
bp committed
890 891
          fsfirst  0 >r
          BEGIN  pause  0=  WHILE  dir?
892
                 dtaname >len s" ."  compare 0<>
bp's avatar
bp committed
893 894 895 896 897
                 dtaname >len s" .." compare 0<> and and
                 IF  \ cr ." dir " dtaname >file type
                     path self
                     @length @time @attr
                     dtaname >len file-widget new
898
                     r> 1+ >r  THEN  fsnext  REPEAT r> ;
bp's avatar
bp committed
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919

        : close   dpy close ;

\ file listbox sort methods                            10apr04py

        : name<= ( w1 w2 -- flag )   >r
          file-widget with text $@ endwith  r>
          file-widget with text $@ endwith  compare 0>= ;

        : date<= ( w1 w2 -- flag )   2dup
          file-widget with time @ endwith  swap
          file-widget with time @ endwith
          2dup = IF  2drop name<=  ELSE  u>= nip nip  THEN ;

        : length<= ( w1 w2 -- flag ) 2dup
          file-widget with size @ endwith swap
          file-widget with size @ endwith
          2dup = IF  2drop name<=  ELSE  u>= nip nip  THEN ;

\ file listbox                                         10apr04py

920
        : widget ( addr len -- object )
bp's avatar
bp committed
921
          scratch 0place
bp's avatar
bp committed
922 923 924 925 926 927 928
          file<= @ F IS lex
          scratch $1C0 read-dir   >r  sp@ r@ sort
          scratch $0C0 read-files >r  sp@ r@ sort
          r> r> + dup 0=
          IF  s" -Empty Directory-" text-label new swap 1+  THEN
          0 1 *filll 2dup   rule new swap 1+ vresize new
          ['] <= F IS lex ;
929 930
        : assign ( addr u file-act path-act <= -- )
          file<= !  bind path  bind file ;
bp's avatar
bp committed
931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
        : dispose path dispose file dispose super dispose ;
class;

\ file selector box                                    22sep07py
window class file-selector
public: icon-but ptr reloader   button ptr oker
        infotextfield ptr path  infotextfield ptr file
        viewport ptr file-list  cell var ok?
        vabox ptr sort-menu     info-menu ptr sort-title
        modal ptr close-it      actor ptr do-ok
        early by-name           early by-date
        early by-length         method reload
how:    AVariable file<=
        : cancel ( -- )  ok? off hide :: close ;
        : ok     ( -- )  ok? on  hide
          0 path get  file get  do-ok store :: close ;
        : close  cancel ;
        : !file  ( addr len -- )  file assign ;

\ file selector box                                    10apr04py

        : !path  ( addr len -- )
          2dup  s" ."  compare
bp's avatar
bp committed
954
          IF    path get  >r scratch r@ move scratch r@ '/' -scan
bp's avatar
bp committed
955
                2over s" .." compare 0=
bp's avatar
bp committed
956
                IF    2swap 2drop 2dup + >r 1- '/' -scan
bp's avatar
bp committed
957 958
                      over + r> over - r@ swap dup >r F delete
                      r> r> swap -
bp's avatar
bp committed
959
                ELSE  2 pick 1+ r> + >r r@ swap safe/string
bp's avatar
bp committed
960
                      s" /" 2over insert insert scratch r> THEN
bp's avatar
bp committed
961
[defined] x11 [IF]     over c@ '/' = IF  path assign  ELSE  2drop  THEN
bp's avatar
bp committed
962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982
[ELSE]          path assign   [THEN]
          ELSE  2drop  THEN
          sort-title get reload ;

\ file selector box                                    10apr04py

        : newdir ( addr len -- object ) \  dta fsetdta
          ^ S[ !file ]S ^ S[ !path ]S file<= @
          file-listbox new ;
        : reload ( addr len -- )
          sort-title assign  path get  newdir
          file-list with  assign  resized  endwith ;
        : by-name
          file-listbox ' name<=   file<= ! s" name"   reload ;
        : by-date
          file-listbox ' date<=   file<= ! s" date"   reload ;
        : by-length
          file-listbox ' length<= file<= ! s" length" reload ;

\ file selector box                                    10apr04py
        : >real-path ( addr n1 -- addr' n2 )
bp's avatar
bp committed
983
[defined] win32 [IF]
bp's avatar
bp committed
984
          over 1+ c@ ': <>
bp's avatar
bp committed
985
[ELSE]    over c@ '/' <>   [THEN]
bp's avatar
bp committed
986
          IF  2dup  pad dup 0 dgetpath drop >len
bp's avatar
bp committed
987 988
[defined] win32 [IF] 2dup bounds ?DO  I c@ '\' = IF  '/' I c!  THEN LOOP
[THEN]        dup IF  2dup + '/' swap c! 1+  THEN
bp's avatar
bp committed
989 990 991 992 993 994 995 996 997 998 999 1000
              dup >r + swap move r> + nip pad swap
          THEN ;
        : sort-menu:    ( -- o )
          ^ ['] by-name   simple new s" name"   menu-entry new
          ^ ['] by-date   simple new s" date"   menu-entry new
          ^ ['] by-length simple new s" length" menu-entry new
          3 vabox new  widget :: xS borderbox ;

\ file selector window                                 10apr04py
        : panel-line ( info l file l path l -- widget )
          >real-path
          ^ ST[ reloader self close-it default! ]ST
bp's avatar
bp committed
1001
          s" Path:" tableinfotextfield new bind path
bp's avatar
bp committed
1002
          2swap ^ ST[ oker self close-it default! ]ST
bp's avatar
bp committed
1003
          -rot  tableinfotextfield new bind file
bp's avatar
bp committed
1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026
          path self  file self   sort-title self  2fill
          ^ S[ s" ."  !path ]S dot-dir    icon-but new
                                   dup bind reloader
          ^ S[ s" .." !path ]S dotdot-dir icon-but new
          2 hatbox new 2 hskips 2skip
                ^ ['] ok     simple new s" OK"   button new
          dup >r                   dup bind oker
          2skip ^ ['] cancel simple new s" Cancel" button new
          3 hatbox new

\ file selector window                                 10apr04py

          5 habox new  3 r> modal new  panel  dup bind close-it
          1 habox new  vfixbox  path get
          1 1 viewport new
          D[ newdir ]D  dup bind file-list
          asliderview new  2 vabox new ;

\ file selector window                                 10apr04py

        : assign ( info len file len path len -- )
          sort-menu self
          s" Sort by" info-menu new bind sort-title
1027
          panel-line  s" File Selector" super assign ;
bp's avatar
bp committed
1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
        : init ( action dpy -- )
          super init  bind do-ok  file-listbox ' name<= file<= !
          sort-menu: bind sort-menu  diro-icon set-icon ;
        : keyed  over #cr =
          IF  close-it keyed  ELSE  super keyed  THEN ;
class;

\ fsel-input                                           10apr04py

minos

: path+file ( path len file len -- file len )
  >r >r tuck scratch 2+ swap move  scratch 2+ swap  r> r> 2swap
1041
  '/' -scan + swap 2dup + 0 swap c! move  scratch 2+ >len ;
bp's avatar
bp committed
1042 1043 1044 1045 1046 1047

: fsel-action ( info len file1 len1 path1 len1 simple -- )
  screen self file-selector new
  file-selector with  assign  0 $10 geometry  show  endwith ;

: fsel-dialog ( info len file1 len1 path1 len1 simple -- )
1048 1049
  screen self file-selector new get-win  swap
  file-selector with set-parent assign 0 $10 geometry
bp's avatar
bp committed
1050 1051 1052 1053 1054 1055
  show endwith ;

\ fsel-input                                           10apr04py

: ?suffix ( path len suffix len -- path len' )
\  2swap tuck scratch 2+ move scratch 2+ swap 2swap
bp's avatar
bp committed
1056
  dup >r 2over dup r> - 0max safe/string 2over compare
bp's avatar
bp committed
1057 1058 1059 1060 1061
  IF    >r >r tuck scratch 2+ swap move  scratch 2+ swap  r> r>
        2swap + swap 2dup + 0 swap c! move  scratch 2+ >len
  ELSE  2drop  THEN ;

previous minos
bp's avatar
bp committed
1062

1063 1064 1065 1066
[ELSE]
: path+file ( path len file len -- file len )
  >r >r tuck scratch 2+ swap move  scratch 2+ swap  r> r> 2swap
  '/' -scan + swap 2dup + 0 swap c! move  scratch 2+ >len ;
bp's avatar
bp committed
1067
[THEN]
bp's avatar
bp committed
1068