extra/curses/curses.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.strings assocs byte-arrays
   4 combinators continuations destructors fry io.encodings.8-bit
   5 io io.encodings.string io.encodings.utf8 kernel locals math
   6 namespaces prettyprint sequences classes.struct
   7 strings threads curses.ffi unix.ffi ;
   8 IN: curses
   9
  10 SYMBOL: curses-windows
  11 SYMBOL: current-window
  12
  13 CONSTANT: ERR -1
  14 CONSTANT: FALSE 0
  15 CONSTANT: TRUE 1
  16 : >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
  17
  18 ERROR: duplicate-window window ;
  19 ERROR: unnamed-window window ;
  20 ERROR: window-not-found window ;
  21 ERROR: curses-failed ;
  22 ERROR: unsupported-curses-terminal ;
  23
  24 : get-window ( string -- window )
  25     dup curses-windows get at*
  26     [ nip ] [ drop window-not-found ] if ;
  27
  28 : window-ptr ( string -- window ) get-window ptr>> ;
  29
  30 : curses-error ( n -- ) ERR = [ curses-failed ] when ;
  31
  32 : curses-ok? ( -- ? )
  33     { 0 1 2 } [ isatty 0 = not ] all? ;
  34
  35 : with-curses ( quot -- )
  36     curses-ok? [ unsupported-curses-terminal ] unless
  37     H{ } clone curses-windows [
  38         initscr curses-error
  39         [
  40             curses-windows get values [ dispose ] each
  41             nocbreak curses-error
  42             echo curses-error
  43             endwin curses-error
  44         ] [ ] cleanup
  45     ] with-variable ; inline
  46
  47 : with-window ( name quot -- )
  48     [ window-ptr current-window ] dip with-variable ; inline
  49
  50 TUPLE: curses-window
  51     name
  52     parent-name
  53     ptr
  54     { lines integer initial: 0 }
  55     { columns integer initial: 0 }
  56     { y integer initial: 0 }
  57     { x integer initial: 0 }
  58
  59     { cbreak initial: t }
  60     { echo initial: t }
  61     { raw initial: f }
  62
  63     { scrollok initial: t }
  64     { leaveok initial: f }
  65
  66     idcok idlok immedok
  67     { keypad initial: f } ;
  68
  69 M: curses-window dispose ( window -- )
  70     ptr>> delwin curses-error ;
  71
  72 <PRIVATE
  73
  74 : add-window ( window -- )
  75     dup name>> [ unnamed-window ] unless*
  76     curses-windows get 2dup key?
  77     [ duplicate-window ] [ set-at ] if ;
  78
  79 : delete-window ( window -- )
  80     curses-windows get 2dup key?
  81     [ delete-at ] [ drop window-not-found ] if ;
  82
  83 : window-params ( window -- lines columns y x )
  84     { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
  85
  86 : setup-window ( window -- )
  87     {
  88         [
  89             dup
  90             dup parent-name>> [
  91                 window-ptr swap window-params derwin
  92             ] [
  93                 window-params newwin
  94             ] if* [ curses-error ] keep >>ptr drop
  95         ]
  96         [ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ]
  97         [ echo>> [ echo ] [ noecho ] if curses-error ]
  98         [ raw>> [ raw ] [ noraw ] if curses-error ]
  99         [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
 100         [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
 101         [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
 102         [ add-window ]
 103     } cleave ;
 104
 105 PRIVATE>
 106
 107 : add-curses-window ( window -- )
 108     [ setup-window ] [ ] [ dispose ] cleanup ;
 109
 110 : (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ;
 111 : wnrefresh ( window -- ) window-ptr (curses-window-refresh) ;
 112 : curses-refresh ( -- ) current-window get (curses-window-refresh) ;
 113
 114 : (curses-wprint) ( window-ptr string -- )
 115     waddstr curses-error ;
 116
 117 : curses-nwrite ( window string -- )
 118     [ window-ptr ] dip (curses-wprint) ;
 119
 120 : curses-wprint ( window string -- )
 121     [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
 122
 123 : curses-printf ( window string -- )
 124     [ window-ptr dup dup ] dip (curses-wprint)
 125     "\n" (curses-wprint)
 126     (curses-window-refresh) ;
 127
 128 : curses-writef ( window string -- )
 129     [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
 130
 131 :: (curses-read) ( window-ptr n encoding -- string )
 132     n <byte-array> :> buf
 133     window-ptr buf n wgetnstr curses-error
 134     buf encoding alien>string ;
 135
 136 : curses-read ( window n -- string )
 137     utf8 [ window-ptr ] 2dip (curses-read) ;
 138
 139 : curses-erase ( window -- ) window-ptr werase curses-error ;
 140
 141 : move-cursor ( window-name y x -- )
 142     [
 143         window-ptr c-window memory>struct
 144         {
 145             [ ]
 146             [ (curses-window-refresh) ]
 147             [ _curx>> ]
 148             [ _cury>> ]
 149         } cleave
 150     ] 2dip mvcur curses-error (curses-window-refresh) ;
 151
 152 : delete-line ( window-name y -- )
 153     [ window-ptr dup ] dip
 154     0 wmove curses-error wdeleteln curses-error ;
 155
 156 : insert-blank-line ( window-name y -- )
 157     [ window-ptr dup ] dip
 158     0 wmove curses-error winsertln curses-error ;
 159
 160 : insert-line ( window-name y string -- )
 161     [ dupd insert-blank-line ] dip
 162     curses-writef ;