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 curses.ffi 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 SYMBOL: current-window
  11
  12 CONSTANT: COLOR_BLACK 0
  13 CONSTANT: COLOR_RED   1
  14 CONSTANT: COLOR_GREEN 2
  15 CONSTANT: COLOR_YELLO 3
  16 CONSTANT: COLOR_BLUE  4
  17 CONSTANT: COLOR_MAGEN 5
  18 CONSTANT: COLOR_CYAN  6
  19 CONSTANT: COLOR_WHITE 7
  20
  21 : >BOOLEAN ( ? -- TRUE/FALSE ) TRUE FALSE ? ; inline
  22
  23 ERROR: curses-failed ;
  24 ERROR: unsupported-curses-terminal ;
  25
  26 : curses-error ( n -- ) ERR = [ curses-failed ] when ;
  27
  28 : curses-ok? ( -- ? )
  29     { 0 1 2 } [ isatty 0 = not ] all? ;
  30
  31 TUPLE: curses-window < disposable
  32     ptr
  33     parent-window
  34     { lines integer initial: 0 }
  35     { columns integer initial: 0 }
  36     { y integer initial: 0 }
  37     { x integer initial: 0 }
  38
  39     { cbreak initial: t }
  40     { echo initial: t }
  41     { raw initial: f }
  42
  43     { scrollok initial: t }
  44     { leaveok initial: f }
  45
  46     idcok idlok immedok
  47     { keypad initial: t }
  48
  49     { encoding initial: utf8 } ;
  50
  51 : <curses-window> ( -- window )
  52     curses-window new-disposable ;
  53
  54 M: curses-window dispose* ( window -- )
  55     ptr>> delwin curses-error ;
  56
  57 <PRIVATE
  58
  59 : window-params ( window -- lines columns y x )
  60     { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
  61
  62 : set-cbreak/raw ( cbreak raw -- )
  63     [ drop raw ] [
  64         [ cbreak ] [ nocbreak ] if
  65     ] if curses-error ;
  66
  67 : apply-options ( window -- )
  68     {
  69         [ [ cbreak>> ] [ raw>> ] bi set-cbreak/raw ]
  70         [ echo>> [ echo ] [ noecho ] if curses-error ]
  71         [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
  72         [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
  73         [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
  74     } cleave ;
  75
  76 SYMBOL: n-registered-colors
  77
  78 MEMO: register-color ( fg bg -- n )
  79     [ n-registered-colors get ] 2dip init_pair curses-error
  80     n-registered-colors [ get ] [ inc ] bi ;
  81
  82 PRIVATE>
  83
  84 : setup-window ( window -- window )
  85     [
  86         dup
  87         dup parent-window>> [
  88             ptr>> swap window-params derwin
  89         ] [
  90             window-params newwin
  91         ] if* [ curses-error ] keep >>ptr &dispose
  92     ] [ apply-options ] bi ;
  93
  94 : with-window ( window quot -- )
  95     [ current-window ] dip with-variable ; inline
  96
  97 <PRIVATE
  98
  99 : init-colors ( -- )
 100     has_colors [
 101         1 n-registered-colors set
 102         \ register-color reset-memoized
 103         start_color curses-error
 104     ] when ;
 105
 106 : curses-pointer-error ( ptr/f -- ptr )
 107     dup [ curses-failed ] unless ; inline
 108
 109 PRIVATE>
 110
 111 : with-curses ( window quot -- )
 112     curses-ok? [ unsupported-curses-terminal ] unless
 113     [
 114         [
 115             initscr curses-pointer-error
 116             >>ptr dup apply-options
 117         ] dip
 118         erase curses-error
 119         init-colors
 120         [
 121             [ endwin curses-error ] [ ] cleanup
 122         ] curry with-window
 123     ] with-destructors ; inline
 124
 125
 126 <PRIVATE
 127
 128 : (window-curses-refresh) ( window-ptr -- ) wrefresh curses-error ; inline
 129 : (window-curses-write) ( string window-ptr -- ) swap waddstr curses-error ; inline
 130
 131 :: (window-curses-read) ( n encoding window-ptr -- string )
 132     [
 133         n 1 + malloc &free :> str
 134         window-ptr str n wgetnstr curses-error
 135         str encoding alien>string
 136     ] with-destructors ; inline
 137
 138 : (window-curses-getch) ( window -- key )
 139     wgetch [ curses-error ] keep ;
 140
 141 : (window-curses-move) ( y x window-ptr -- )
 142     -rot wmove curses-error ; inline
 143
 144 : (window-insert-blank-line) ( y window-ptr -- )
 145     [ 0 swap (window-curses-move) ]
 146     [ winsertln curses-error ] bi ; inline
 147
 148 : (window-curses-addch) ( ch window-ptr -- )
 149     swap waddch curses-error ; inline
 150
 151 PRIVATE>
 152
 153 : window-curses-refresh ( window -- ) ptr>> (window-curses-refresh) ;
 154 : curses-refresh ( -- ) current-window get window-curses-refresh ;
 155
 156 : window-curses-write ( string window -- )
 157     ptr>> (window-curses-write) ;
 158 : curses-write ( string -- )
 159     current-window get window-curses-write ;
 160
 161 : window-curses-nl ( window -- )
 162     [ "\n" ] dip ptr>> (window-curses-write) ;
 163 : curses-nl ( -- )
 164     current-window get window-curses-nl ;
 165
 166 : window-curses-print ( string window -- )
 167     ptr>> [ (window-curses-write) ]
 168     [ "\n" swap (window-curses-write) ] bi ;
 169 : curses-print ( string -- )
 170     current-window get window-curses-print ;
 171
 172 : window-curses-print-refresh ( string window -- )
 173     ptr>> [ (window-curses-write) ]
 174     [ "\n" swap (window-curses-write) ]
 175     [ (window-curses-refresh) ] tri ;
 176 : curses-print-refresh ( string -- )
 177     current-window get window-curses-print-refresh ;
 178
 179 : window-curses-write-refresh ( string window -- )
 180     ptr>> [ (window-curses-write) ] [ (window-curses-refresh) ] bi ;
 181 : curses-write-refresh ( string -- )
 182     current-window get window-curses-write-refresh ;
 183
 184 : window-curses-read ( n window -- string )
 185     [ encoding>> ] [ ptr>> ] bi (window-curses-read) ;
 186 : curses-read ( n -- string )
 187     current-window get window-curses-read ;
 188
 189 : window-curses-getch ( window -- key )
 190     ptr>> (window-curses-getch) ;
 191 : curses-getch ( -- key )
 192     current-window get window-curses-getch ;
 193
 194 : window-curses-erase ( window -- )
 195     ptr>> werase curses-error ;
 196 : curses-erase ( -- )
 197     current-window get window-curses-erase ;
 198
 199 : window-curses-move ( y x window -- )
 200     ptr>> [ (window-curses-move) ] [ (window-curses-refresh) ] bi ;
 201 : curses-move ( y x -- )
 202     current-window get window-curses-move ;
 203
 204 : window-delete-line ( y window -- )
 205     ptr>> [ 0 swap (window-curses-move) ]
 206     [ wdeleteln curses-error ] bi ;
 207 : delete-line ( y -- )
 208     current-window get window-delete-line ;
 209
 210 : window-insert-blank-line ( y window -- )
 211     ptr>> (window-insert-blank-line) ;
 212 : insert-blank-line ( y -- )
 213     current-window get window-insert-blank-line ;
 214
 215 : window-insert-line ( string y window -- )
 216     ptr>> [ (window-insert-blank-line) ]
 217     [ (window-curses-write) ] bi ;
 218 : insert-line ( string y -- )
 219     current-window get window-insert-line ;
 220
 221 : window-curses-addch ( ch window -- )
 222     ptr>> (window-curses-addch) ;
 223 : curses-addch ( ch -- )
 224     current-window get window-curses-addch ;
 225
 226 : window-curses-color ( foreground background window -- )
 227     [
 228         2dup [ COLOR_WHITE = ] [ COLOR_BLACK = ] bi* and
 229         [ 2drop 0 ] [ register-color ] if COLOR_PAIR
 230     ] dip ptr>> swap wattron curses-error ;
 231 : curses-color ( foreground background -- )
 232     current-window get window-curses-color ;