\ component                                            04mar00py

: get-win ( -- win )  & displays @ object class?
  IF  displays get-win  ELSE  widget dpy get-win  THEN ;

modal class component
    early open immediate
    early dialog immediate
    early open-app immediate
    early menu immediate
    early open-win
    method params
    method widget
  how:
    : widget s" Nothing" text-label new ;
    : params   DF[ 0 ]DF s" No Title" ;
    : init ( -- ) ^>^^ assign
        widget 1 ^ params 2drop nip super init ;
    : open-win ( -- )  self params rot drop
        screen self window new  window with  assign show  endwith ;
    : make     ( o -- win )
        new, dup >o params o> rot drop
        screen self window new  window with  assign ^  endwith ;
    : open,     make  window with  show  endwith ;
    : dialog,   make  get-win
        swap window with  set-parent show  endwith ;
    : open-app, make  window with  show up@ app ! 1 apprefcnt +! endwith ;
    : menu,     ( o -- o ) >o widget o> ;
    : open     ( -- )     o@ state @
        IF postpone ALiteral postpone open, ELSE open, THEN ;
    : dialog     ( -- )     o@ state @
        IF postpone ALiteral postpone dialog, ELSE dialog, THEN ;
    : open-app     ( -- )     o@ state @
        IF postpone ALiteral postpone open-app, ELSE open-app, THEN ;
    : menu     ( -- )     ^ state @
        IF postpone ALiteral postpone menu, ELSE menu, THEN ;
class;

: 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 -- )
  new-component  window with  show up@ app ! 1 apprefcnt +!  endwith ;

\ empty menu stub

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;

\ empty box stub

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;

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" ;
    : init ( -- )  screen self super init ^>^^
        widget 1 ^ params 2>r nip modal new 2r> assign ;
    : open,     new,  window with  show  endwith ;
    : dialog,   new,  get-win
        swap window with  set-parent show  endwith ;
    : open-app, new,  window with  show up@ app ! 1 apprefcnt +!  endwith ;
    : open     ( -- )     o@ state @
        IF postpone ALiteral postpone open, ELSE open, THEN ;
    : dialog     ( -- )     o@ state @
        IF postpone ALiteral postpone dialog, ELSE dialog, THEN ;
    : open-app     ( -- )     o@ state @
        IF postpone ALiteral postpone open-app, ELSE open-app, THEN ;
class;

\ OpenGL canvas                                        22jun02py

also opengl also glconst

[defined] win32 [IF]
        | 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
[defined] win32 [IF]
        cell var oldbm          cell var dibptr
[THEN] [defined] x11 [IF]
        cell var cmap
[THEN]
        widget ptr outer

\ OpenGL canvas                                        08jul00py
how:
[defined] x11 [IF]
        | 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+ -- )
          super init  >callback  IS drawer  ^^ bind outer ;
        : 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 @
          glxwin @ ?dup  IF  over swap XDestroyWindow drop
                             glxwin off  THEN
          glxpm  @ ?dup  IF  over swap glXDestroyGLXPixmap
                             glxpm  off  THEN
          pixmap @ ?dup  IF  over swap XFreePixmap
                             pixmap off  THEN
          cmap   @ ?dup  IF  over swap XFreeColormap
                             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
          IF    dpy drawable drop 2swap swap XCreateColormap dup cmap !
          ELSE  2drop dpy xrc cmap @  THEN
              xswa XSetWindowAttributes colormap !
          dpyscreen BlackPixel dup
              xswa XSetWindowAttributes border_pixel !
              xswa XSetWindowAttributes background_pixel !

          event-mask  xswa XSetWindowAttributes event_mask !

          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
          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
          dpy xrc dpy @ dpy get-win
          w @ 4 max 3 + -4 and h @ 4 max
          visinfo @ XVisualInfo depth @
          XCreatePixmap dup pixmap !
          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
[defined] win32 [IF]
        : 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+ -- )
          super init  >callback  IS drawer  ^^ bind outer ;

\ 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
[defined] win32 [IF]
          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]  ;
        : dispose destroy-pixmap  [defined] x11 [IF]
          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
[defined] x11 [IF]
          glxpm @
          IF  dpy xrc dpy @ glxpm @ glXSwapBuffers  THEN
[THEN]    rendered on ;

\ OpenGL canvas                                        22oct06py

        : draw ( -- )
          rendered @ 0=  IF  render  THEN
[defined] x11 [IF]   pixmap @
          IF    0 0 xywh 2swap pixmap @ dpy image
          ELSE  glxwin @
            IF  dpy xrc dpy @ glxwin @ glXSwapBuffers
                rendered off  THEN
          THEN
[THEN]
[defined] x11_ximage [IF]   0 0 xywh 2swap 0 sp@ >r 0 sp@ r>
          pixmap @ dpy xrc dpy @ XMesaFindBuffer
          XMesaGetBackBuffer drop nip dpy ximage  [THEN]
[defined] win32 [IF]   0 0 xywh 2swap pixmap @ dpy image  [THEN]
        ;

\ 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

: GL[  postpone :[ glcanvas postpone with ;        immediate
: ]GL  glcanvas postpone endwith  postpone ]: ;    immediate

: CV[  postpone :[ canvas postpone with ;        immediate
: ]CV  canvas postpone endwith  postpone ]: ;    immediate

\ helper words for Theseus                             21sep07py

: T"   postpone S" ;                             immediate

[defined] VFXFORTH [IF]
    Variable ^^bind-string
    : ^^bind  postpone dup  postpone bind2 ;     immediate
[ELSE]
    : ^^bind  postpone dup  postpone bind ;      immediate restrict
[THEN]


\ 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 )
          scrolls @ cols @ * dup >r + rows @ cols @ * modf r> -
          'start + cols @ -trailing ;
        : !resized  s" n" !textwh
          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 -- )
          fnt16 self 0= IF  fnt draw  EXIT  THEN  { x y dpy }
          BEGIN  dup  WHILE  2dup scan8 dup
                 IF    tuck x y dpy fnt draw
                       dup textwh @ * x + to x safe/string
                 ELSE  2drop  THEN
                 2dup scan16 dup
                 IF    tuck x y dpy fnt16 draw
                       dup textwh @ * x + to x safe/string
                 ELSE  2drop  THEN  REPEAT  2drop ;

\ 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
             pos @ 'line drop
             dup 1+ xchar- tuck - negate pos +!
             dup selw @ + xchar- xchar+ swap - selw !
             EXIT
          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 @ @ +
          dup selw @ + 2dup min -rot max { color s e }
          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
                  safe/string  2over swap s I csize +
                  swap color 8 >> .text
               THEN  texth @ + cols @ +LOOP
          2drop ;

\ IO-Window                                            16jun02py

        : draw-io ( x y dpyo -- )
          dup displays with clipy endwith
          over + { dpyo sclip eclip }
          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
               THEN  texth @ + cols @ +LOOP  2drop ;
        : 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
          start rows @ $20 + $-20 and
          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
          scrolls @ 1+ rows @ modf scrolls !
          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
     pos @ at? nip - 'line 2swap 6 colors @ 8 >> .text 2drop ;
        : 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
          BEGIN  dup pos @ r@ modf r@ - + dup 0>=  WHILE
                 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
[defined] x11 [IF]            XC_xterm   [THEN]
[defined] win32 [IF]          IDC_IBEAM  [THEN]  dpy set-cursor  ;

\ 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 )
          pos @ typebuf @ @ + cols @ /modf swap ;
        : 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 @
          { s1 c# p s }
          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
          c# cursor# ! p pos ! s1 selw ! ;

\ IO-Window                                            30dec99py
        : clrline   flush  curoff pos @ dup cols @ modf - pos !
          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 ;
        : cr  ( -- ) flush cols @ pos @ over modf - c
          resize! c@ ?EXIT show-you ;
        : curup    cols @ negate c ;
        : curdown  cols @        c ;

\ IO-Window                                            09mar99py
        : selecting ( -- )  flush  textwh 2@ swap
          DOPRESS  x @ y @ p- 2swap swap >r /f swap r> /f at-sel ;
        : (dpy  [defined] x11 [IF]    dpy get-win  dpy xrc dpy @
          [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
          ?DO  drop cols @ I over modf -
               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

        : copyline  >r >r at? drop cols @ * 'line
          r@ swap 4 pick min dup 3 pin move
          r> over r> min ;
        : >atxy  ( msap xy -- msap )  at? >r >r $100 /modf swap
          2dup at r> rot <>
          IF  >r copyline r> rdrop over >r  THEN  r>
          - + dup 0min dup negate c - 2 pick over -
          0min dup c + ;

\ IO-Window                                            07jun03py
        : keyed ( key state -- )
          over shift-keys?  IF  2drop  EXIT  THEN
          BEGIN  keys @ @ $1F >=  WHILE  pause  REPEAT $18 lshift or
          keys @ dup @ 1+ $1F min dup keys @ ! cells + ! ;
        boxchar :: handle-key?
        : key?  ( -- flag )
          keys @ @ 0= IF  pause  THEN  keys @ @ 0> ;
        : getkey ( -- key )  keys @ @
          IF    keys @ cell+ @  keys @ 8 + dup cell- $78 move
                -1 keys @ +! dup $18 rshift kbshift ! $FFFFFF and
          ELSE  0  THEN ;
        : key   ( -- key )  flush  1 cursor# ! curon
          BEGIN  key?  0= WHILE
                  dpy xrc fid [defined] VFXFORTH [IF] #1 [ELSE] #50 [THEN] idle
          REPEAT
          getkey curoff ;

\ IO-Window                                            06jan05py

        : decode ( m s addr pos char -- m s addr pos flag )
          kbshift @ $40 and  IF  drop 0 EXIT  THEN
[defined] (Ftast [IF]  dup $FFBE $FFCA within
          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
[defined] VFXFORTH [IF] PCdecode  [ELSE]
[defined] utf-8 [IF]  xdecode [ELSE] PCdecode [THEN] [THEN] ;

\ IO-Window                                            01jan05py

        : init ( w h -- )  $80 keys Handle!  keys @ off
        ^ CK[ 2swap y @ -
              texth @ /f swap x @ - textwh @ /f swap 2swap
              1 and  IF  drop mark-selection  EXIT  THEN
              1 and 0=  IF  2drop (dpy @select paste-selection
                            EXIT  THEN
              8 << or kbshift @ $40 or keyed ]CK >callback
          assign  defocuscol @ @ color ! ;
        : close  #cr 0 keyed S" bye"  bounds ?DO  i c@ 0 keyed  LOOP ;
        : dispose start HandleOff  keys HandleOff
          typebuf HandleOff  ^ dpy cleanup  super dispose ;
class;

[defined] VFXFORTH [IF]
    Defer WinI/O
    Defer terminal-menu             ' noop IS terminal-menu
    2Variable map-size              80 24 map-size 2!
    2Variable map-pos
    #1000 Value MaxScroll
    terminal ptr term
    hbox ptr term-menu
    rule ptr term-last

    : 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
          1 1 viewport new
              D[ map-size 2@ terminal new dup F bind term ]D
        s" VFX Forth Dialog" assign
        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 !
    MaxScroll term scrollback WinI/O ;
[ELSE]
\ Window IO words                                      10apr04py
terminal uptr term      Forward openw
[THEN]
| : 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 ;

: WINkey? ( -- flag )  term? term key? ;
: WINkey  ( -- key )   term? term key ;
: WINdecode            term? term decode ;
[defined] VFXFORTH [IF]
    ' WINdecode IS decode
[THEN]

\ Window IO words                                      05jan05py
[defined] VFXFORTH [IF]
    : >out  WINat? out ! op-line# ! ;
    : WINsetpos' ( x y mode sid -- ior ) 2drop swap WINat 0 >out ;
    : WINgetpos' ( mode sid -- x y ior ) 2drop WINat? swap 0 ;
    : WINflush' ( sid -- ior ) drop WINflush 0 ;
    : WINkey' drop WINkey ;
    : WINkey?' drop WINkey? ;
    : WINemit' drop WINemit >out ;
    : WINtype' drop WINtype >out ;
    : WINcr' drop WINcr >out ;
\    : WINlf' drop WINclrline >out ;
    : WINpage' drop WINpage >out ;
    : WINcurleft' drop WINcurleft >out ;
    : WINemit?' drop true ;
    : WINaccept' drop PCaccept ;
    Create WINio-table
    ' .s , \ open
    ' false , \ close
    ' drop , \ read
    ' drop , \ write
    ' WINkey' ,
    ' WINkey?' ,
    ' WINkey' ,
    ' WINkey?' ,
    ' WINaccept' , \ accept
    ' 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 ,
    : WINdisplay ( -- ) WINio-sid dup op-handle ! to PauseConsole ;
    : WINkeyboard ( -- ) WINio-sid ip-handle ! ;
    :noname  WINdisplay  WINkeyboard ; IS WinI/O
[ELSE]
Output: WINdisplay
        WINemit true WINcr WINtype PCdel WINpage
        WINat WINat? WINform  noop noop WINflush
        WINcuron WINcuroff WINcurleft WINcurrite WINclrline [

[defined] xaccept [IF]
        Input:  WINkeyboard
        WINkey WINkey? WINdecode xaccept false [
[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
      1 1 viewport new
          D[ map-size 2@ terminal new dup F bind term ]D
      s" bigFORTH Dialog" assign
      terminal-menu
      map-size 2@ geometry
      map-pos 2@ d0= 0= IF  map-pos 2@ repos  THEN
      sync show endwith
  MaxScroll term scrollback
  event-task' task's term dup @
  0= IF  term self swap !  ELSE  drop  THEN
  ['] WINi/o IS standardi/o  WINi/o ;
[THEN]

\ 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
  ELSE  ^ '"' parse key-actor new  THEN ;        immediate

\ : term-dpy  term dpy dpy self ;

\ 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
          size @ 0 <# #S #> 0 textsize drop wsize !
          S" 00may99"       0 textsize drop wdate !
          S" 00:00:00"      0 textsize drop wtime ! ;
[defined] x11 [IF]   : dir@ attr @ $C >> ;             [THEN]
[defined] win32 [IF] : dir@ attr @ $10 and 0<> 4 and ; [THEN]

\ 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 >>
          { iw m cc }  dpy mask
          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
          m wsize @ + 0 p- size @ 0 <# #S #>
          2swap cc .text ;

\ 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
[defined] x11 [IF]     : dir? @attr $C >> 4 = ;        [THEN]
[defined] win32 [IF]   : dir? @attr $10 and 0<> ;      [THEN]
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 )
          over >len '/' -scan + dup push '*' swap w!
          fsfirst  0 >r
          BEGIN  pause  0=  WHILE  dir?
                 dtaname >len s" ."  compare 0<>
                 dtaname >len s" .." compare 0<> and and
                 IF  \ cr ." dir " dtaname >file type
                     path self
                     @length @time @attr
                     dtaname >len file-widget new
                     r> 1+ >r  THEN  fsnext  REPEAT r> ;

        : 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

        : widget ( addr len -- object )
          scratch 0place
          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 ;
        : assign ( addr u file-act path-act <= -- )
          file<= !  bind path  bind file ;
        : 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
          IF    path get  >r scratch r@ move scratch r@ '/' -scan
                2over s" .." compare 0=
                IF    2swap 2drop 2dup + >r 1- '/' -scan
                      over + r> over - r@ swap dup >r F delete
                      r> r> swap -
                ELSE  2 pick 1+ r> + >r r@ swap safe/string
                      s" /" 2over insert insert scratch r> THEN
[defined] x11 [IF]     over c@ '/' = IF  path assign  ELSE  2drop  THEN
[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 )
[defined] win32 [IF]
          over 1+ c@ ': <>
[ELSE]    over c@ '/' <>   [THEN]
          IF  2dup  pad dup 0 dgetpath drop >len
[defined] win32 [IF] 2dup bounds ?DO  I c@ '\' = IF  '/' I c!  THEN LOOP
[THEN]        dup IF  2dup + '/' swap c! 1+  THEN
              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
          s" Path:" tableinfotextfield new bind path
          2swap ^ ST[ oker self close-it default! ]ST
          -rot  tableinfotextfield new bind file
          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
          panel-line  s" File Selector" super assign ;
        : 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
  '/' -scan + swap 2dup + 0 swap c! move  scratch 2+ >len ;

: 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 -- )
  screen self file-selector new get-win  swap
  file-selector with set-parent assign 0 $10 geometry
  show endwith ;

\ fsel-input                                           10apr04py

: ?suffix ( path len suffix len -- path len' )
\  2swap tuck scratch 2+ move scratch 2+ swap 2swap
  dup >r 2over dup r> - 0max safe/string 2over compare
  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

[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 ;
[THEN]

