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 ;
10 SYMBOL: curses-windows
11 SYMBOL: current-window
16 : >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
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 ;
24 : get-window ( string -- window )
25 dup curses-windows get at*
26 [ nip ] [ drop window-not-found ] if ;
28 : window-ptr ( string -- window ) get-window ptr>> ;
30 : curses-error ( n -- ) ERR = [ curses-failed ] when ;
33 { 0 1 2 } [ isatty 0 = not ] all? ;
35 : with-curses ( quot -- )
36 curses-ok? [ unsupported-curses-terminal ] unless
37 H{ } clone curses-windows [
40 curses-windows get values [ dispose ] each
45 ] with-variable ; inline
47 : with-window ( name quot -- )
48 [ window-ptr current-window ] dip with-variable ; inline
54 { lines integer initial: 0 }
55 { columns integer initial: 0 }
56 { y integer initial: 0 }
57 { x integer initial: 0 }
63 { scrollok initial: t }
64 { leaveok initial: f }
67 { keypad initial: f } ;
69 M: curses-window dispose ( window -- )
70 ptr>> delwin curses-error ;
74 : add-window ( window -- )
75 dup name>> [ unnamed-window ] unless*
76 curses-windows get 2dup key?
77 [ duplicate-window ] [ set-at ] if ;
79 : delete-window ( window -- )
80 curses-windows get 2dup key?
81 [ delete-at ] [ drop window-not-found ] if ;
83 : window-params ( window -- lines columns y x )
84 { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
86 : setup-window ( window -- )
91 window-ptr swap window-params derwin
94 ] if* [ curses-error ] keep >>ptr drop
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 ]
107 : add-curses-window ( window -- )
108 [ setup-window ] [ ] [ dispose ] cleanup ;
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) ;
114 : (curses-wprint) ( window-ptr string -- )
115 waddstr curses-error ;
117 : curses-nwrite ( window string -- )
118 [ window-ptr ] dip (curses-wprint) ;
120 : curses-wprint ( window string -- )
121 [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
123 : curses-printf ( window string -- )
124 [ window-ptr dup dup ] dip (curses-wprint)
126 (curses-window-refresh) ;
128 : curses-writef ( window string -- )
129 [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
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 ;
136 : curses-read ( window n -- string )
137 utf8 [ window-ptr ] 2dip (curses-read) ;
139 : curses-erase ( window -- ) window-ptr werase curses-error ;
141 : move-cursor ( window-name y x -- )
143 window-ptr c-window memory>struct
146 [ (curses-window-refresh) ]
150 ] 2dip mvcur curses-error (curses-window-refresh) ;
152 : delete-line ( window-name y -- )
153 [ window-ptr dup ] dip
154 0 wmove curses-error wdeleteln curses-error ;
156 : insert-blank-line ( window-name y -- )
157 [ window-ptr dup ] dip
158 0 wmove curses-error winsertln curses-error ;
160 : insert-line ( window-name y string -- )
161 [ dupd insert-blank-line ] dip