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