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 classes.struct
7 strings threads curses.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 ;
23 : get-window ( string -- window )
24 dup curses-windows get at*
25 [ nip ] [ drop window-not-found ] if ;
27 : window-ptr ( string -- window ) get-window ptr>> ;
29 : curses-error ( n -- ) ERR = [ curses-failed ] when ;
31 : with-curses ( quot -- )
32 H{ } clone curses-windows [
35 curses-windows get values [ dispose ] each
40 ] with-variable ; inline
42 : with-window ( name quot -- )
43 [ window-ptr current-window ] dip with-variable ; inline
49 { lines integer initial: 0 }
50 { columns integer initial: 0 }
51 { y integer initial: 0 }
52 { x integer initial: 0 }
58 { scrollok initial: t }
59 { leaveok initial: f }
62 { keypad initial: f } ;
64 M: curses-window dispose ( window -- )
65 ptr>> delwin curses-error ;
69 : add-window ( window -- )
70 dup name>> [ unnamed-window ] unless*
71 curses-windows get 2dup key?
72 [ duplicate-window ] [ set-at ] if ;
74 : delete-window ( window -- )
75 curses-windows get 2dup key?
76 [ delete-at ] [ drop window-not-found ] if ;
78 : window-params ( window -- lines columns y x )
79 { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
81 : setup-window ( window -- )
86 window-ptr swap window-params derwin
89 ] if* [ curses-error ] keep >>ptr drop
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 ]
102 : add-curses-window ( window -- )
103 [ setup-window ] [ ] [ dispose ] cleanup ;
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) ;
109 : (curses-wprint) ( window-ptr string -- )
110 waddstr curses-error ;
112 : curses-nwrite ( window string -- )
113 [ window-ptr ] dip (curses-wprint) ;
115 : curses-wprint ( window string -- )
116 [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
118 : curses-printf ( window string -- )
119 [ window-ptr dup dup ] dip (curses-wprint)
121 (curses-window-refresh) ;
123 : curses-writef ( window string -- )
124 [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
126 : (curses-read) ( window-ptr n encoding -- string )
127 [ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
129 : curses-read ( window n -- string )
130 utf8 [ window-ptr ] 2dip (curses-read) ;
132 : curses-erase ( window -- ) window-ptr werase curses-error ;
134 : move-cursor ( window-name y x -- )
136 window-ptr c-window memory>struct
139 [ (curses-window-refresh) ]
143 ] 2dip mvcur curses-error (curses-window-refresh) ;
145 : delete-line ( window-name y -- )
146 [ window-ptr dup ] dip
147 0 wmove curses-error wdeleteln curses-error ;
149 : insert-blank-line ( window-name y -- )
150 [ window-ptr dup ] dip
151 0 wmove curses-error winsertln curses-error ;
153 : insert-line ( window-name y string -- )
154 [ dupd insert-blank-line ] dip