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 classes.struct combinators continuations destructors
   5 fry io io.encodings.8-bit io.encodings.string io.encodings.utf8
   6 io.streams.c kernel libc locals math memoize multiline
   7 namespaces prettyprint sequences strings threads ;
   8 IN: curses
   9
  10 QUALIFIED-WITH: curses.ffi ffi
  11
  12 SYMBOL: current-window
  13
  14 CONSTANT: COLOR_BLACK 0
  15 CONSTANT: COLOR_RED   1
  16 CONSTANT: COLOR_GREEN 2
  17 CONSTANT: COLOR_YELLO 3
  18 CONSTANT: COLOR_BLUE  4
  19 CONSTANT: COLOR_MAGEN 5
  20 CONSTANT: COLOR_CYAN  6
  21 CONSTANT: COLOR_WHITE 7
  22
  23 CONSTANT: A_NORMAL      0
  24 CONSTANT: A_ATTRIBUTES  -256
  25 CONSTANT: A_CHARTEXT    255
  26 CONSTANT: A_COLOR       65280
  27 CONSTANT: A_STANDOUT    65536
  28 CONSTANT: A_UNDERLINE   131072
  29 CONSTANT: A_REVERSE     262144
  30 CONSTANT: A_BLINK       524288
  31 CONSTANT: A_DIM         1048576
  32 CONSTANT: A_BOLD        2097152
  33 CONSTANT: A_ALTCHARSET  4194304
  34 CONSTANT: A_INVIS       8388608
  35 CONSTANT: A_PROTECT     16777216
  36 CONSTANT: A_HORIZONTAL  33554432
  37 CONSTANT: A_LEFT        67108864
  38 CONSTANT: A_LOW         134217728
  39 CONSTANT: A_RIGHT       268435456
  40 CONSTANT: A_TOP         536870912
  41 CONSTANT: A_VERTICAL    1073741824
  42
  43 ERROR: curses-failed ;
  44 ERROR: unsupported-curses-terminal ;
  45
  46 <PRIVATE
  47
  48 : >BOOLEAN ( ? -- TRUE/FALSE ) ffi:TRUE ffi:FALSE ? ; inline
  49
  50 : curses-pointer-error ( ptr/f -- ptr )
  51     dup [ curses-failed ] unless ; inline
  52 : curses-error ( n -- ) ffi:ERR = [ curses-failed ] when ;
  53
  54 PRIVATE>
  55
  56 : curses-ok? ( -- ? )
  57     { 0 1 2 } [ isatty 0 = not ] all? ;
  58
  59 TUPLE: curses-window < disposable
  60     ptr
  61     parent-window
  62     { lines integer initial: 0 }
  63     { columns integer initial: 0 }
  64     { y integer initial: 0 }
  65     { x integer initial: 0 }
  66
  67     { cbreak initial: t }
  68     { echo initial: t }
  69     { raw initial: f }
  70
  71     { scrollok initial: t }
  72     { leaveok initial: f }
  73
  74     idcok idlok immedok
  75     { keypad initial: t }
  76
  77     { encoding initial: utf8 } ;
  78
  79 : <curses-window> ( -- window )
  80     curses-window new-disposable ;
  81
  82 M: curses-window dispose* ( window -- )
  83     ptr>> ffi:delwin curses-error ;
  84
  85 <PRIVATE
  86
  87 : window-params ( window -- lines columns y x )
  88     { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
  89
  90 : set-cbreak/raw ( cbreak raw -- )
  91     [ drop ffi:raw ] [
  92         [ ffi:cbreak ] [ ffi:nocbreak ] if
  93     ] if curses-error ;
  94
  95 : apply-options ( window -- )
  96     {
  97         [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
  98         [ echo>> [ ffi:echo ] [ ffi:noecho ] if curses-error ]
  99         [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi ffi:scrollok curses-error ]
 100         [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi ffi:leaveok curses-error ]
 101         [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi ffi:keypad curses-error ]
 102     } cleave ;
 103
 104 SYMBOL: n-registered-colors
 105
 106 MEMO: register-color ( fg bg -- n )
 107     [ n-registered-colors get ] 2dip ffi:init_pair curses-error
 108     n-registered-colors [ get ] [ inc ] bi ;
 109
 110 : init-colors ( -- )
 111     ffi:has_colors [
 112         1 n-registered-colors set
 113         \ register-color reset-memoized
 114         ffi:start_color curses-error
 115     ] when ;
 116
 117 PRIVATE>
 118
 119 : setup-window ( window -- window )
 120     [
 121         dup
 122         dup parent-window>> [
 123             ptr>> swap window-params ffi:derwin
 124         ] [
 125             window-params ffi:newwin
 126         ] if* [ curses-error ] keep >>ptr &dispose
 127     ] [ apply-options ] bi ;
 128
 129 : with-window ( window quot -- )
 130     [ current-window ] dip with-variable ; inline
 131
 132 : with-curses ( window quot -- )
 133     curses-ok? [ unsupported-curses-terminal ] unless
 134     [
 135         '[
 136             ffi:initscr curses-pointer-error
 137             >>ptr dup apply-options
 138             ffi:erase curses-error
 139             init-colors
 140             _ with-window
 141         ] [ ffi:endwin curses-error ] [ ] cleanup
 142     ] with-destructors ; inline
 143
 144 TUPLE: curses-terminal < disposable
 145     infd outfd ptr ;
 146
 147 : <curses-terminal> ( infd outfd ptr -- curses-terminal )
 148     curses-terminal new-disposable
 149         swap >>ptr
 150         swap >>outfd
 151         swap >>infd ;
 152
 153 M: curses-terminal dispose
 154     [ outfd>> fclose ] [ infd>> fclose ]
 155     [ ptr>> ffi:delscreen ] tri ;
 156
 157 : init-terminal ( terminal -- curses-terminal )
 158     "xterm-color" swap [ "rb" fopen ] [ "wb" fopen ] bi
 159     [ ffi:newterm curses-pointer-error ] 2keep <curses-terminal> ;
 160
 161 : start-remote-curses ( terminal window -- curses-terminal )
 162     [
 163         init-terminal
 164         ffi:initscr curses-pointer-error drop
 165         dup ptr>> ffi:set_term curses-pointer-error drop
 166     ] dip apply-options ;
 167
 168 <PRIVATE
 169
 170 : (wcrefresh) ( window-ptr -- ) ffi:wrefresh curses-error ; inline
 171 : (wcwrite) ( string window-ptr -- ) swap ffi:waddstr curses-error ; inline
 172
 173 :: (wcread) ( n encoding window-ptr -- string )
 174     [
 175         n 1 + malloc &free :> str
 176         window-ptr str n ffi:wgetnstr curses-error
 177         str encoding alien>string
 178     ] with-destructors ; inline
 179
 180 : (wcmove) ( y x window-ptr -- )
 181     -rot ffi:wmove curses-error ; inline
 182
 183 : (winsert-blank-line) ( y window-ptr -- )
 184     [ 0 swap (wcmove) ]
 185     [ ffi:winsertln curses-error ] bi ; inline
 186
 187 : (waddch) ( ch window-ptr -- )
 188     swap ffi:waddch curses-error ; inline
 189
 190 : (wgetch) ( window -- key )
 191     ffi:wgetch [ curses-error ] keep ; inline
 192
 193 : (wattroff) ( attribute window-ptr -- )
 194     swap ffi:wattroff curses-error ; inline
 195
 196 : (wattron) ( attribute window-ptr -- )
 197     swap ffi:wattron curses-error ; inline
 198
 199 PRIVATE>
 200
 201 : wcrefresh ( window -- ) ptr>> (wcrefresh) ;
 202 : crefresh ( -- ) current-window get wcrefresh ;
 203
 204 : wcnl ( window -- ) [ "\n" ] dip ptr>> (wcwrite) ;
 205 : cnl ( -- ) current-window get wcnl ;
 206
 207 : wcwrite ( string window -- ) ptr>> (wcwrite) ;
 208 : cwrite ( string -- ) current-window get wcwrite ;
 209
 210 : wcprint ( string window -- )
 211     ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ] bi ;
 212 : cprint ( string -- ) current-window get wcprint ;
 213
 214 : wcprintf ( string window -- )
 215     ptr>> [ (wcwrite) ] [ "\n" swap (wcwrite) ]
 216     [ (wcrefresh) ] tri ;
 217 : cprintf ( string -- ) current-window get wcprintf ;
 218
 219 : wcwritef ( string window -- )
 220     ptr>> [ (wcwrite) ] [ (wcrefresh) ] bi ;
 221 : cwritef ( string -- ) current-window get wcwritef ;
 222
 223 : wcread ( n window -- string )
 224     [ encoding>> ] [ ptr>> ] bi (wcread) ;
 225 : curses-read ( n -- string ) current-window get wcread ;
 226
 227 : wgetch ( window -- key ) ptr>> (wgetch) ;
 228 : getch ( -- key ) current-window get wgetch ;
 229
 230 : waddch ( ch window -- ) ptr>> (waddch) ;
 231 : addch ( ch -- ) current-window get waddch ;
 232
 233 : werase ( window -- ) ptr>> ffi:werase curses-error ;
 234 : erase ( -- ) current-window get werase ;
 235
 236 : wcmove ( y x window -- )
 237     ptr>> [ (wcmove) ] [ (wcrefresh) ] bi ;
 238 : cmove ( y x -- ) current-window get wcmove ;
 239
 240 : wdelete-line ( y window -- )
 241     ptr>> [ 0 swap (wcmove) ] [ ffi:wdeleteln curses-error ] bi ;
 242 : delete-line ( y -- ) current-window get wdelete-line ;
 243
 244 : winsert-blank-line ( y window -- )
 245     ptr>> (winsert-blank-line) ;
 246 : insert-blank-line ( y -- )
 247     current-window get winsert-blank-line ;
 248
 249 : winsert-line ( string y window -- )
 250     ptr>> [ (winsert-blank-line) ] [ (wcwrite) ] bi ;
 251 : insert-line ( string y -- )
 252     current-window get winsert-line ;
 253
 254 : wattron ( attribute window -- ) ptr>> (wattron) ;
 255 : attron ( attribute -- ) current-window get wattron ;
 256
 257 : wattroff ( attribute window -- ) ptr>> (wattroff) ;
 258 : attroff ( attribute -- ) current-window get wattroff ;
 259
 260 : wall-attroff ( window -- ) [ A_NORMAL ] dip wattroff ;
 261 : all-attroff ( -- ) current-window get wall-attroff ;
 262
 263 : wccolor ( foreground background window -- )
 264     [
 265         2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
 266         [ 2drop 0 ] [ register-color ] if ffi:COLOR_PAIR
 267     ] dip ptr>> (wattron) ;
 268
 269 : ccolor ( foreground background -- )
 270     current-window get wccolor ;