scsh-conservatory
/
scsh-ncurses
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
scsh-ncurses/scheme/ncurses.scm

1598 lines
35 KiB
Scheme
Raw Normal View History

first commit
2004-09-07 05:13:21 -04:00
;;record-types:
;;dienen dazu, C-Pointer zu verpacken.
;;window
(define-record-type :window window
(make-window c-pointer)
window?
(c-pointer window-c-pointer))
;; screen
(define-record-type :screen screen
(make-screen c-pointer)
screen?
(c-pointer screen-c-pointer))
;;*************************************************************************
;;Konstanten:
(define err -1)
;;Fehlerbehandlung:
;;Es kommt bei Funktionen mit Integer als R<>ckgabe im Fehlerfall
;;ERR zur<75>ck. Dann wird ein Fehler ausgel<65>st. Gleiches gilt, wenn
;;ein NULL-Pointer zur<75>ckkommt.
(define-condition-type 'curses-error '(error))
(define curses-error?
(condition-predicate 'curses-error))
;;OK ist 0
;;Funktionen, die int nur zur Fehlerbehandlung zurueckgeben
(define (return-curses-code-int function-name code)
(if (zero? code)
(values)
(signal 'curses-error function-name)))
(define (raise-curses-error function-name)
(signal 'curses-error function-name))
(define (raise-curses-noinit-error)
(signal 'curses-error "use init-screen first"))
(define standard-screen)
(import-lambda-definition set-stdscr-internal
()
"scsh_stdscr")
(define set-standard-screen
(lambda ()
(set! standard-screen (make-window (set-stdscr-internal)))))
;;*********************************************************************
;;Bibliotheks-Funktionen
;;*********************************************************************
;; ALLGEMEINE
;;Initialisierung
;;initscr liefert einen Zeiger auf stdscr
(import-lambda-definition init-screen-internal
()
"scsh_initscr")
(define init-screen
(lambda ()
(define res (init-screen-internal))
(begin (set-standard-screen)
(make-window (or res
(raise-curses-error "init-screen"))))))
;; (if )))
;; (make-window
;; (or (init-screen-internal)
;; (raise-curses-error "init-screen")))))
(import-lambda-definition newterm-internal
(type outfd infd)
"scsh-newterm")
(define (newterm type outfd infd)
(make-screen (or (newterm-internal type
(port->fdes outfd)
(port->fdes infd))
(raise-curses-error "newterm"))))
;;Beenden
(import-lambda-definition endwin
()
"scsh_endwin")
(import-lambda-definition isendwin
()
"scsh_isendwin")
(import-lambda-definition delscreen
()
"scsh_delscreen")
;;Hilfsfunktionen
(import-lambda-definition unctrl-internal
(c)
"scsh_unctrl")
(define (unctrl c)
(or (unctrl-internal c)
(raise-curses-error "unctrl")))
(import-lambda-definition keyname-internal
(c)
"scsh_keyname")
(define (keyname c)
(or (keyname-internal c)
(raise-curses-error "keyname")))
(import-lambda-definition filter
()
"scsh_filter")
(import-lambda-definition use_env
(f)
"scsh_use_env")
(import-lambda-definition putwin-internal
(win file)
"scsh_putwin")
(define (putwin win file)
(return-curses-code-int "putwin"
(putwin-internal (window-c-pointer win)
(port->fdes file))))
(import-lambda-definition getwin-internal
(file)
"scsh_getwin")
(define (getwin file)
(make-window (or (getwin-internal (port->fdes file))
(raise-curses-error "getwin"))))
(import-lambda-definition delay-output-internal
(ms)
"scsh_delay_output")
(define (delay-output ms)
(return-curses-code-int "delay-output"
(delay-output-internal ms)))
(import-lambda-definition flushinp-internal
()
"scsh_flushinp")
(define (flushinp)
(return-curses-code-int "flushinp"
(flushinp-internal)))
(import-lambda-definition curses-version-internal
()
"scsh_curses_version")
(define (curses-version)
(or (curses-version-internal)
(raise-curses-error "curses-version")))
;;Einstellungen
(import-lambda-definition use-default-colors-internal
()
"scsh_use_default_colors")
(define (use-default-colors)
(return-curses-code-int "use-default-colors"
(use-default-colors-internal)))
(import-lambda-definition assume-default-colors-internal
(fg bg)
"scsh_assume_default_colors")
(define (assume-default-colors fg bg)
(return-curses-code-int "assume-default-colors"
(assume-default-colors-internal fg bg)))
(import-lambda-definition define-key-internal
(def keyc)
"scsh_define_key")
(define (define-key def keyc)
(return-curses-code-int "define-key"
(define-key-internal def keyc)))
;;*************************************************************************
;;TERMINAL
;;Eigenschaften
(import-lambda-definition baudrate-internal
()
"scsh_baudrate")
(define (baudrate)
(or (baudrate-internal)
(raise-curses-error "bauderate")))
(import-lambda-definition erasechar
()
"scsh_erasechar")
(import-lambda-definition has_ic
()
"scsh_has_ic")
(import-lambda-definition has_il
()
"scsh_has_il")
(import-lambda-definition killchar
()
"scsh_killchar")
(import-lambda-definition longname-internal
()
"scsh_longname")
(define (longname)
(or (longname-internal)
(raise-curses-error "longname")))
(import-lambda-definition termname-internal
()
"scsh_termname")
(define (termname)
(or (termname-internal)
(raise-curses-error "termname")))
(import-lambda-definition has-key-internal
(ch)
"scsh_has_key")
(define (has-key ch)
(or (has-key-internal ch)
(raise-curses-error "has-key")))
;;Farbe
(import-lambda-definition start-color-internal
()
"scsh_start_color")
(define (start-color)
(return-curses-code-int "start-color"
(start-color-internal)))
(import-lambda-definition init-pair-internal
(pair f b)
"scsh_init_pair")
(define (init-pair pair f b)
(return-curses-code-int "init-pair"
(init-pair-internal pair f b)))
(import-lambda-definition init-color-internal
(color r g b)
"scsh_init_color")
(define (init-color color r g b)
(return-curses-code-int "init-color"
(init-color-internal color r g b)))
(import-lambda-definition has-colors
()
"scsh_has_colors")
(import-lambda-definition can-change-colors
()
"scsh_can_change_colors")
(import-lambda-definition color-pair
(num)
"scsh_color_pair")
;;Eingabe:
(import-lambda-definition cbreak-internal
()
"scsh_cbreak")
(define (cbreak)
(return-curses-code-int "cbreak"
(cbreak-internal)))
(import-lambda-definition nocbreak-internal
()
"scsh_no_cbreak")
(define (nocbreak)
(return-curses-code-int "nocbreak"
(nocbreak-internal)))
(import-lambda-definition echo-internal
()
"scsh_echo")
(define (echo)
(return-curses-code-int "echo"
(echo-internal)))
(import-lambda-definition noecho-internal
()
"scsh_noecho")
(define (noecho)
(return-curses-code-int "noecho"
(noecho-internal)))
(import-lambda-definition halfdelay-internal
(tenth)
"scsh_halfdelay")
(define (halfdelay tenth)
(return-curses-code-int "halfdelay"
(halfdelay-internal tenth)))
(import-lambda-definition intrflush-internal
(win bf)
"scsh_intrflush")
(define (intrflush win bf)
(return-curses-code-int "intrflush"
(intrflush-internal (window-c-pointer win)
bf)))
(import-lambda-definition keypad-internal
(win bf)
"scsh_keypad")
(define (keypad win bf)
(return-curses-code-int "keypad"
(keypad-internal (window-c-pointer win)
bf)))
(import-lambda-definition meta-internal
(win bf)
"scsh_meta")
(define (meta win bf)
(return-curses-code-int "meta"
(meta-internal (window-c-pointer win)
bf)))
(import-lambda-definition nodelay-internal
(win bf)
"scsh_nodelay")
(define (nodelay win bf)
(return-curses-code-int "nodelay"
(nodelay-internal (window-c-pointer win)
bf)))
(import-lambda-definition raw-internal
()
"scsh_raw")
(define (raw)
(return-curses-code-int "raw"
(raw-internal)))
(import-lambda-definition noraw-internal
()
"scsh_noraw")
(define (noraw)
(return-curses-code-int "noraw"
(noraw-internal)))
(import-lambda-definition qiflush
()
"scsh_qiflush")
(import-lambda-definition noqiflush
()
"scsh_noqiflush")
;;Terminalfunktionen
(import-lambda-definition beep-internal
()
"scsh_beep")
(define (beep)
(return-curses-code-int "beep"
(beep-internal)))
(import-lambda-definition flash-internal
()
"scsh_flash")
(define (flash)
(return-curses-code-int "flash"
(flash-internal)))
(import-lambda-definition def-prog-mode-internal
()
"scsh_def_prog_mode")
(define (def-prog-mode)
(return-curses-code-int "def-prog-mode"
(def-prog-mode-internal)))
(import-lambda-definition def-shell-mode-internal
()
"scsh_def_shell_mode")
(define (def-shell-mode)
(return-curses-code-int "def-shell-mode"
(def-shell-mode-internal)))
(import-lambda-definition reset-prog-mode-internal
()
"scsh_reset_prog_mode")
(define (reset-prog-mode)
(return-curses-code-int "reset-prog-mode"
(reset-prog-mode-internal)))
(import-lambda-definition reset-shell-mode-internal
()
"scsh_reset_shell_mode")
(define (reset-shell-mode)
(return-curses-code-int "reset-shell-mode"
(reset-shell-mode-internal)))
(import-lambda-definition resetty-internal
()
"scsh_resetty")
(define (resetty)
(return-curses-code-int "resetty"
(resetty)))
(import-lambda-definition savetty-internal
()
"scsh_savetty")
(define (savetty)
(return-curses-code-int "savetty"
(savetty)))
(import-lambda-definition curs-set-internal
(visibility)
"scsh_curs_set")
(define (curs-set visibility)
(return-curses-code-int "curs-set"
(curs-set-internal visibility)))
(import-lambda-definition napms-internal
(ms)
"scsh_napms")
(define (napms ms)
(return-curses-code-int "napms"
(napms-internal ms)))
(import-lambda-definition mcprint-internal
(data len)
"scsh_mcprint")
(define (mcprint data len)
(return-curses-code-int "mcprint"
(mcprint-internal data len)))
(import-lambda-definition is-term-resized
(lines columns)
"scsh_is_term_resized")
(import-lambda-definition resize-term-internal
(lines columns)
"scsh_resize_term")
(define (resize-term lines columns)
(return-curses-code-int "resize-term"
(resize-term-internal lines columns)))
(import-lambda-definition resizeterm-internal
(lines columns)
"scsh_resizeterm")
(define (resizeterm lines columns)
(return-curses-code-int "resizeterm"
(resizeterm-internal lines columns)))
(import-lambda-definition scr-dump-internal
(filename)
"scsh_scr_dump")
(define (scr-dump filename)
(return-curses-code-int "scr-dump"
(scr-dump-internal filename)))
(import-lambda-definition scr-restore-internal
(filename)
"scsh_scr_restore")
(define (scr-restore filename)
(return-curses-code-int "scr-restore"
(scr-restore-internal filename)))
(import-lambda-definition scr-init-internal
(filename)
"scsh_scr_init")
(define (scr-init filename)
(return-curses-code-int "scr-init"
(scr-init-internal filename)))
(import-lambda-definition scr-set-internal
(filename)
"scsh_scr_set")
(define (scr-set filename)
(return-curses-code-int "scr-set"
(scr-set-internal filename)))
;;mehrere Terminals:
(import-lambda-definition set-term-internal
(new)
"scsh_set_term")
(define (set-term new)
(make-screen (or (set-term-internal (screen-c-pointer new))
(raise-curses-error "set-term"))))
;;*************************************************************************
;;FENSTER
;;Allgemeine
(import-lambda-definition newwin-internal
(height width starty startx)
"scsh_newwin")
(define (newwin h w x y)
(make-window (or (newwin-internal h w x y)
(raise-curses-error "newwin"))))
(import-lambda-definition delwin-internal
(win)
"scsh_delwin")
(define (delwin win)
(return-curses-code-int "delwin"
(delwin-internal (window-c-pointer win))))
(import-lambda-definition mvwin-internal
(win y x)
"scsh_mvwin")
(define (mvwin win y x)
(return-curses-code-int "mvwin"
(mvwin-internal (window-c-pointer win) y x)))
(import-lambda-definition subwin-internal
(orig nlines ncols begin_y begin_x)
"scsh_subwin")
(define (subwin orig nlines ncols begin_y begin_x)
(make-window (or (subwin-internal (window-c-pointer orig)
nlines ncols begin_y begin_x)
(raise-curses-error "subwin"))))
(import-lambda-definition derwin-internal
(orig nlines ncols begin_y begin_x)
"scsh_derwin")
(define (derwin orig nlines ncols begin_y begin_x)
(make-window (or (derwin-internal (window-c-pointer orig)
nlines ncols begin_y begin_x)
(raise-curses-error "derwin"))))
(import-lambda-definition mvderwin-internal
(win par_y par_x)
"scsh_mvderwin")
(define (mvderwin win par_y par_x)
(return-curses-code-int
"mvderwin"
(mvderwin-internal (window-c-pointer win) par_y par_x)))
(import-lambda-definition dupwin-internal
(win)
"scsh_dupwin")
(define (dupwin win)
(make-window (or (dupwin-internal (window-c-pointer win))
(raise-curses-error "dupwin"))))
(import-lambda-definition wsyncup-internal
(win)
"scsh_wsyncup")
(define (wsyncup win)
(or (wsyncup-internal (window-c-pointer win))
(raise-curses-error "wsyncup")))
(import-lambda-definition wcursyncup-internal
(win)
"scsh_wcursyncup")
(define (wcursyncup win)
(or (wcursyncup-internal (window-c-pointer win))
(raise-curses-error "wcursyncup")))
(import-lambda-definition wsyncdown-internal
(win)
"scsh_wsyncdown")
(define (wsyncdown win)
(or (wsyncdown-internal (window-c-pointer win))
(raise-curses-error "wsyncdown")))
(import-lambda-definition syncok-internal
(win bf)
"scsh_syncok")
(define (syncok win bf)
(return-curses-code-int
"syncok"
(syncok-internal (window-c-pointer win) bf)))
(import-lambda-definition wrefresh-internal
(win)
"scsh_wrefresh")
(define (wrefresh win)
(return-curses-code-int
"wrefresh"
(wrefresh-internal (window-c-pointer win))))
(import-lambda-definition wnoutrefresh-internal
(win)
"scsh_wnoutrefresh")
(define (wnoutrefresh win)
(return-curses-code-int
"wnoutrefresh"
(wnoutrefresh-internal (window-c-pointer win))))
(import-lambda-definition redrawwin-internal
(win)
"scsh_redrawwin")
(define (redrawwin win)
(return-curses-code-int
"redrawwin"
(redrawwin-internal (window-c-pointer win))))
(import-lambda-definition doupdate-internal
()
"scsh_doupdate")
(define (doupdate)
(return-curses-code-int
"doupdate"
(doupdate-internal )))
(import-lambda-definition wredrawln-internal
(win beg_line num_lines)
"scsh_wredrawln")
(define (wredrawln win beg_line num_lines)
(return-curses-code-int
"wredrawln"
(wredrawln-internal (window-c-pointer win) beg_line num_lines)))
;;(import-lambda-definition getyx-internal
;; (win)
;; "scsh_getyx")
;;(define (getyx win)
;; (getyx_internal (window-c-pointer win)))
;;(import-lambda-definition getparyx-internal
;; (win y x)
;; "scsh_getparyx")
;;(define (getparyx win y x)
;; (getparyx_internal (window-c-pointer win) y x))
;;(import-lambda-definition getbegyx-internal
;; (win y x)
;; "scsh_getbegyx")
;;(define (getbegyx win y x)
;; (getbegyx_internal (window-c-pointer win) y x))
;;(import-lambda-definition getmaxyx-internal
;; (win y x)
;; "scsh_getmaxyx")
;;(define (getmaxyx win y x)
;; (getmaxyx_internal (window-c-pointer win) y x))
(import-lambda-definition wresize-internal
(win lines columns)
"scsh_wresize")
(define (wresize win lines columns)
(return-curses-code-int
"wresize"
(wresize-internal (window-c-pointer win) lines columns)))
;;Ausgabe-Einstellungen
(import-lambda-definition idlok-internal
(win bf)
"scsh_idlok")
(define (idlok win bf)
(return-curses-code-int
"idlok"
(idlok-internal (window-c-pointer win) bf)))
(import-lambda-definition leaveok-internal
(win bf)
"scsh_leaveok")
(define (leaveok win bf)
(return-curses-code-int
"leaveok"
(leaveok-internal (window-c-pointer win) bf)))
(import-lambda-definition scrollok-internal
(win bf)
"scsh_scrollok")
(define (scrollok win bf)
(return-curses-code-int
"scrollok"
(scrollok-internal (window-c-pointer win) bf)))
(import-lambda-definition idcok-internal
(win bf)
"scsh_idcok")
(define (idcok win bf)
(idcok-internal (window-c-pointer win) bf))
(import-lambda-definition immedok-internal
(win bf)
"scsh_immedok")
(define (immedok win bf)
(immedok-internal (window-c-pointer win) bf))
(import-lambda-definition wsetscrreg-internal
(win top bot)
"scsh_wsetscrreg")
(define (wsetscrreg win top bot)
(return-curses-code-int
"wsetscrreg"
(wsetscrreg-internal (window-c-pointer win) top bot)))
(import-lambda-definition nl-internal
()
"scsh_nl")
(define (nl)
(return-curses-code-int
"nl"
(nl-internal)))
(import-lambda-definition nonl-internal
()
"scsh_nonl")
(define (nonl)
(return-curses-code-int
"nonl"
(nonl-internal)))
;;Text anzeigen
(import-lambda-definition waddch-internal
(win ch)
"scsh_waddch")
(define (waddch win ch)
(return-curses-code-int
"waddch"
(waddch-internal (window-c-pointer win) ch)))
(import-lambda-definition wechochar-internal
(win ch)
"scsh_wechochar")
(define (wechochar win ch)
(return-curses-code-int
"wechochar"
(wechochar-internal (window-c-pointer win) ch)))
(import-lambda-definition waddstr-internal
(win str)
"scsh_waddstr")
(define (waddstr win str)
(return-curses-code-int
"waddstr"
(waddstr-internal (window-c-pointer win) str)))
(import-lambda-definition waddnstr-internal
(win str n)
"scsh_waddnstr")
(define (waddnstr win str n)
(return-curses-code-int
"waddnstr"
(waddnstr-internal (window-c-pointer win) str n)))
(import-lambda-definition winsch-internal
(win ch)
"scsh_winsch")
(define (winsch win ch)
(return-curses-code-int
"winsch"
(winsch-internal (window-c-pointer win) ch)))
(import-lambda-definition winsstr-internal
(win str)
"scsh_winsstr")
(define (winsstr win str)
(return-curses-code-int
"winsstr"
(winsstr-internal (window-c-pointer win) str)))
(import-lambda-definition winsnstr-internal
(win str n)
"scsh_winsnstr")
(define (winsnstr win str n)
(return-curses-code-int
"winsnstr"
(winsnstr-internal (window-c-pointer win) str n)))
;;Attribute
(import-lambda-definition wattroff-internal
(win attrs)
"scsh_wattroff")
(define (wattroff win attrs)
(return-curses-code-int
"wattroff"
(wattroff-internal (window-c-pointer win) attrs)))
(import-lambda-definition wattron-internal
(win attrs)
"scsh_wattron")
(define (wattron win attrs)
(return-curses-code-int
"wattron"
(wattron-internal (window-c-pointer win) attrs)))
(import-lambda-definition wattrset-internal
(win attrs)
"scsh_wattrset")
(define (wattrset win attrs)
(return-curses-code-int
"wattrset"
(wattrset-internal (window-c-pointer win) attrs)))
(import-lambda-definition wstandend-internal
(win)
"scsh_wstandend")
(define (wstandend win)
(return-curses-code-int
"wstandend"
(wstandend-internal (window-c-pointer win))))
(import-lambda-definition wstandout-internal
(win)
"scsh_wstandout")
(define (wstandout win)
(return-curses-code-int
"wstandout"
(wstandout-internal (window-c-pointer win))))
;;Background:
(import-lambda-definition wbkgdset-internal
(win ch)
"scsh_wbkgdset")
(define (wbkgdset win ch)
(wbkgdset-internal (window-c-pointer win) ch))
(import-lambda-definition wbkgd-internal
(win ch)
"scsh_wbkgd")
(define (wbkgd win ch)
(return-curses-code-int
"wbkgd"
(wbkgd-internal (window-c-pointer win) ch)))
(import-lambda-definition getbkgd-internal
(win)
"scsh_getbkgd")
(define (getbkgd win)
(getbkgd-internal (window-c-pointer win)))
;;Umrandung des Fensters:
(import-lambda-definition wborder-internal
(win ls rs ts bs tl tr bl br)
"scsh_wborder")
(define (wborder win ls rs ts bs tl tr bl br)
(return-curses-code-int
"wboredr"
(wborder-internal (window-c-pointer win) ls rs ts bs tl tr bl br)))
(import-lambda-definition box-internal
(win verch horch)
"scsh_box")
(define (box win verch horch)
(return-curses-code-int
"box"
(box-internal
(window-c-pointer win) verch horch)))
(import-lambda-definition whline-internal
(win ch n)
"scsh_whline")
(define (whline win ch n)
(return-curses-code-int
"whline"
(whline-internal
(window-c-pointer win) ch n)))
(import-lambda-definition wvline-internal
(win ch n)
"scsh_wvline")
(define (wvline win ch n)
(return-curses-code-int
"wvline"
(wvline-internal
(window-c-pointer win) ch n)))
;;Cursor
(import-lambda-definition scroll-internal
(win)
"scsh_scroll")
(define (scroll win)
(return-curses-code-int
"scroll"
(scroll-internal
(window-c-pointer win))))
(import-lambda-definition wscl-internal
(win n)
"scsh_wscrl")
(define (wscrl win n)
(return-curses-code-int
"wscrl"
(wscl-internal
(window-c-pointer win) n)))
(import-lambda-definition wmove-internal
(win y x)
"scsh_wmove")
(define (wmove win y x)
(return-curses-code-int
"wmove"
(wmove-internal
(window-c-pointer win) y x)))
;;Eingabe
(import-lambda-definition wgetch-internal
(win)
"scsh_wgetch")
(define (wgetch win)
(nodelay win #t)
(let ((ch (wgetch-internal (window-c-pointer win))))
(if (not (= err ch))
ch
(begin
(select-port-channels #f (current-input-port))
(nodelay win #f)
(wgetch-internal (window-c-pointer win))))))
(define (wgetstr win)
(let loop ((str ""))
(keypad win #t)
(let ((ch (wgetch win)))
(cond
;;newline
((= ch 10)(begin
(keypad win #f)
str))
;;backspace
((= ch key-backspace)
(if (= (string-length str) 0)
(loop str)
(begin
;;letztes Zeichen l<>schen
(backspace win)
(loop (substring str 0 (- (string-length str) 1))))))
;;sonst
(else
(if (> ch 255)
(loop str)
(loop (string-append str (string (ascii->char ch))))))))))
(define (wgetnstr win n)
(let loop ((str "") (count 0))
(keypad win #t)
(if (<= n 0)
;;Spezialfall n<=0 -> nur echo ausschalten und "" zurueckgeben
(begin (noecho)
(let ((ch (ascii->char(wgetch win))))
(if (equal? #\newline ch)
;;R<>ckkehr
(begin (echo)
(keypad win #f)
str)
;;warten auf newline
(loop str count))))
;;n>0 -> n Zeichen lesen (oder newline), dann noecho
(let ((ch (wgetch win)))
(cond
;;newline -> R<>ckkehr
((= ch 10) (begin (echo)
(keypad win #f)
str))
;;backspace
((= ch key-backspace)
(if (= count 0)
(loop "" count)
(if (= count n )
(begin
(echo)
(back win)
(wdelch win)
(wrefresh win)
(loop (substring str 0 (- count 1)) (- count 1 )))
(begin
(backspace win)
(loop (substring str 0 (- count 1)) (- count 1))))))
;;sonst
(else (if (or (>= count n) (> ch 255))
(loop str count)
(let ((newstr (string-append str
(string (ascii->char ch)))))
(if (= count (- n 1))
(begin
(noecho) (loop newstr (+ count 1)))
(loop newstr (+ count 1)))))))))))
;; (if (>= count n )
;; ;; wenn newline kommt->fertig, sonst ignorieren
;; (if (equal? #\newline ch)
;; (begin
;; (echo)
;; str)
;; (loop str count))
;; ;; wenn newline kommt->fertig, sonst anhaengen
;; (let ((newstr (string-append str (string ch))))
;; (if (equal? #\newline ch)
;; str
;; ab dem n-ten Zeichen wird die Eingabe nicht "geechot"
;; (if (= count (- n 1))
;; (begin
;; (noecho)
;; (loop newstr (+ count 1)))
;; (loop newstr (+ count 1))))))))))
(import-lambda-definition winch-internal
(win)
"scsh_winch")
(define (winch win)
(winch-internal (window-c-pointer win)))
(import-lambda-definition winstr-internal
(win)
"scsh_winstr")
(define (winstr win)
(or (winstr-internal (window-c-pointer win))
(raise-curses-error "winstr")))
(import-lambda-definition winnstr-internal
(win)
"scsh_winnstr")
(define (winnstr win n)
(or (winnstr-internal (window-c-pointer win) n)
(raise-curses-error "winnstr")))
;;Loeschen
(import-lambda-definition werase-internal
(win)
"scsh_werase")
(define (werase win)
(return-curses-code-int
"werase"
(werase-internal
(window-c-pointer win))))
(import-lambda-definition wclear-internal
(win)
"scsh_wclear")
(define (wclear win)
(return-curses-code-int
"wclear"
(wclear-internal
(window-c-pointer win))))
(import-lambda-definition wclrtobot-internal
(win)
"scsh_wclrtobot")
(define (wclrtobot win)
(return-curses-code-int
"wclrtobot"
(wclrtobot-internal
(window-c-pointer win))))
(import-lambda-definition wclrtoeol-internal
(win)
"scsh_wclrtoeol")
(define (wclrtoeol win)
(return-curses-code-int
"wclrtoeol"
(wclrtoeol-internal
(window-c-pointer win))))
(import-lambda-definition clearok-internal
(win bf)
"scsh_clearok")
(define (clearok win bf)
(return-curses-code-int
"clearok"
(clearok-internal
(window-c-pointer win) bf)))
(import-lambda-definition wdelch-internal
(win)
"scsh_wdelch")
(define (wdelch win)
(return-curses-code-int
"wdelch"
(wdelch-internal
(window-c-pointer win))))
(import-lambda-definition wdeleteln-internal
(win)
"scsh_wdeleteln")
(define (wdeleteln win)
(return-curses-code-int
"wdeleteln"
(wdeleteln-internal
(window-c-pointer win))))
(import-lambda-definition winsertln-internal
(win)
"scsh_winsertln")
(define (winsertln win)
(return-curses-code-int
"winsertln"
(winsertln-internal
(window-c-pointer win))))
(import-lambda-definition winsdelln-internal
(win n)
"scsh_winsdelln")
(define (winsdelln win n)
(return-curses-code-int
"winsdelln"
(winsdelln-internal
(window-c-pointer win) n)))
;;mehrere Fenster
(import-lambda-definition overlay-internal
(srcwin dstwin)
"scsh_overlay")
(define (overlay srcwin dstwin)
(return-curses-code-int
"overlay"
(overlay-internal
(window-c-pointer srcwin) (window-c-pointer dstwin))))
(import-lambda-definition overwrite-internal
(srcwin dstwin)
"scsh_overwrite")
(define (overwrite srcwin dstwin)
(return-curses-code-int
"overwrite"
(overwrite-internal
(window-c-pointer srcwin) (window-c-pointer dstwin))))
(import-lambda-definition copywin-internal
(srcwin dstwin sminrow smincol dminrow dmincol dmaxrow dmaxcol overlay)
"scsh_copywin")
(define (copywin srcwin dstwin sminrow smincol dminrow dmincol dmaxrow
dmaxcol overlay)
(return-curses-code-int
"copywin"
(copywin-internal
(window-c-pointer srcwin) (window-c-pointer dstwin)
sminrow smincol dminrow dmincol dmaxrow dmaxcol overlay)))
;;Eigenschaften
(import-lambda-definition touchline-internal
(win start count)
"scsh_touchline")
(define (touchline win start count)
(return-curses-code-int
"touchline"
(touchline-internal (window-c-pointer win) start count)))
(import-lambda-definition touchwin-internal
(win)
"scsh_touchwin")
(define (touchwin win)
(return-curses-code-int
"touchwin"
(touchwin-internal (window-c-pointer win))))
(import-lambda-definition untouchwin-internal
(win)
"scsh_untouchwin")
(define (untouchwin win)
(return-curses-code-int
"untouchwin"
(untouchwin-internal (window-c-pointer win))))
(import-lambda-definition wtouchln-internal
(win y n changed)
"scsh_wtouchln")
(define (wtouchln win y n changed)
(return-curses-code-int
"wtouchln"
(wtouchln-internal (window-c-pointer win) y n changed)))
(import-lambda-definition is-linetouched-internal
(win line)
"scsh_is_linetouched")
(define (is-linetouched win line)
(is-linetouched-internal (window-c-pointer win) line))
(import-lambda-definition is-wintouched-internal
(win)
"scsh_is_wintouched")
(define (is-wintouched win)
(is-wintouched-internal (window-c-pointer win)))
;;*************************************************************************
;;PADS
(import-lambda-definition newpad-internal
(nlines ncols)
"scsh_newpad")
(define (newpad nlines ncols)
(make-window (or (newpad-internal nlines ncols)
(raise-curses-error "newpad"))))
(import-lambda-definition subpad-internal
(orig nlines ncols begin_y begin_x)
"scsh_subpad")
(define (subpad orig nlines ncols begin_y begin_x)
(make-window (or (subpad-internal
(window-c-pointer orig)
nlines ncols begin_y begin_x)
(raise-curses-error "newpad"))))
(import-lambda-definition prefresh-internal
(pad pminrow pmincol sminrow smincol smaxrow smaxcol)
"scsh_prefresh")
(define (prefresh pad pminrow pmincol sminrow smincol smaxrow smaxcol )
(return-curses-code-int
"prefresh"
(prefresh-internal
(window-c-pointer pad) pminrow pmincol sminrow smincol smaxrow smaxcol)))
(import-lambda-definition pnoutrefresh-internal
(pad pminrow pmincol sminrow smincol smaxrow smaxcol)
"scsh_pnoutrefresh")
(define (pnoutrefresh pad pminrow pmincol sminrow smincol smaxrow smaxcol )
(return-curses-code-int
"pnoutrefresh"
(pnoutrefresh-internal
(window-c-pointer pad) pminrow pmincol sminrow smincol smaxrow smaxcol)))
(import-lambda-definition pechochar-internal
(pad ch)
"scsh_pechochar")
(define (pechochar pad ch)
(return-curses-code-int
"pechochar"
(pechochar-internal (window-c-pointer pad) ch)))
;;*************************************************************************
;;KONSTANTEN
;;Standardscreen (s.o.)
;;Lines/Cols
(import-lambda-definition COLS
()
"scsh_COLS")
(import-lambda-definition LINES
()
"scsh_LINES")
;;Attribute
(import-lambda-definition A-NORMAL
()
"scsh_A_NORMAL")
(import-lambda-definition A-STANDOUT
()
"scsh_A_STANDOUT")
(import-lambda-definition A-UNDERLINE
()
"scsh_A_UNDERLINE")
(import-lambda-definition A-REVERSE
()
"scsh_A_REVERSE")
(import-lambda-definition A-BLINK
()
"scsh_A_BLINK")
(import-lambda-definition A-DIM
()
"scsh_A_DIM")
(import-lambda-definition A-BOLD
()
"scsh_A_BOLD")
(import-lambda-definition A-PROTECT
()
"scsh_A_PROTECT")
(import-lambda-definition A-INVIS
()
"scsh_A_INVIS")
(import-lambda-definition A-ALTCHARSET
()
"scsh_A_ALTCHARSET")
(import-lambda-definition COLOR-BLACK
()
"scsh_COLOR_BLACK")
(import-lambda-definition COLOR-RED
()
"scsh_COLOR_RED")
(import-lambda-definition COLOR-GREEN
()
"scsh_COLOR_GREEN")
(import-lambda-definition COLOR-YELLOW
()
"scsh_COLOR_YELLOW")
(import-lambda-definition COLOR-BLUE
()
"scsh_COLOR_BLUE")
(import-lambda-definition COLOR-MAGENTA
()
"scsh_COLOR_MAGENTA")
(import-lambda-definition COLOR-CYAN
()
"scsh_COLOR_CYAN")
(import-lambda-definition COLOR-WHITE
()
"scsh_COLOR_WHITE")
(import-lambda-definition wprintw-internal
(win str)
"scsh_wprintw")
(define (wprintw win str)
(return-curses-code-int
"wprintw"
(wprintw-internal (window-c-pointer win) str)))
;;*************************************************************************
;;STDSCR-FUNKTIONEN
;;diese werden auf scheme-seite neu definiert, um moeglichst viel
;;komplexitaet auf dieser seite zu halten.
(define (refresh)
(wrefresh standard-screen))
(define (move y x)
(wmove standard-screen y x))
(define (setscrreg top bot)
(wsetscrreg standard-screen top bot))
(define (scrl n)
(wscrl standard-screen n))
(define (addch ch)
(waddch standard-screen ch))
(define (echochar ch)
(wechochar standard-screen ch))
(define (addstr str)
(waddstr standard-screen str))
(define (addnstr str n)
(waddnstr standard-screen str n))
(define (insch ch)
(winsch standard-screen ch))
(define (insstr str)
(winsstr standard-screen str))
(define (insnstr str n)
(winsnstr standard-screen str n))
(define (printw str)
(wprintw standard-screen str))
(define (attroff attrs)
(wattroff standard-screen attrs))
(define (attron attrs)
(wattron standard-screen attrs))
(define (attrset attrs)
(wattrset standard-screen attrs))
(define (standend)
(wstandend standard-screen))
(define (standout)
(wstandout standard-screen))
(define (bkgdset ch)
(wbkgdset standard-screen ch))
(define (bkgd ch)
(wbkgd standard-screen ch))
(define (border ls rs ts bs tl tr bl br)
(wborder standard-screen ls rs ts bs tl tr bl br))
(define (hline ch n)
(whline standard-screen ch n))
(define (vline ch n)
(wvline standard-screen ch n))
(define (getch)
(wgetch standard-screen))
(define (getstr)
(wgetstr standard-screen))
(define (getnstr n)
(wgetnstr standard-screen n))
(define (erase)
(werase standard-screen ))
(define (clear)
(wclear standard-screen))
(define (clrtobot)
(wclrtobot standard-screen))
(define (clrtoeol)
(wclrtoeol standard-screen))
(define (delch)
(wdelch standard-screen))
(define (deleteln)
(wdeleteln standard-screen))
(define (insdelln n)
(winsdelln standard-screen n))
(define (insertln)
(winsertln standard-screen))
;;*************************************************************************
;;"MVW"-Funktionen.
;;bewegen den Cursor im uebergebenen Fenster und fuehren die entsprechende
;;Aktion aus. Auch sie sind nur in scheme implementiert.
(define (mvwaddch win y x ch)
(begin (wmove win y x)
(waddch win ch)))
(define (mvwaddstr win y x str)
(begin (wmove win y x)
(waddstr win str)))
(define (mvwaddnstr win y x str n)
(begin (wmove win y x)
(waddnstr win str n)))
(define (mvwinsch win y x ch)
(begin (wmove win y x)
(winsch win ch)))
(define (mvwinsstr win y x str)
(begin (wmove win y x)
(winsstr win str)))
(define (mvwinsnstr win y x str n)
(begin (wmove win y x)
(winsnstr win str n)))
(define (mvwprintw win y x str)
(begin (wmove win y x)
(wprintw win str)))
(define (mvwhline win y x ch n)
(begin (wmove win y x)
(whline win ch n)))
(define (mvwvline win y x ch n)
(begin (wmove win y x)
(wvline win ch n)))
(define (mvwgetch win y x)
(begin (wmove win y x)
(wgetch win )))
(define (mvwgetstr win y x)
(begin (wmove win y x)
(wgetstr win )))
(define (mvwgetnstr win y x n)
(begin (wmove win y x)
(wgetnstr win n)))
(define (mvwdelch win y x)
(begin (wmove win y x)
(wdelch win)))
;;*********************************************************************
;;zus<75>tzliche Funktionen
;;Cursor-Positionen
(import-lambda-definition gety-internal
(win)
"scsh_gety")
(define gety
(lambda(win)
(gety-internal (window-c-pointer win))))
(import-lambda-definition getx-internal
(win)
"scsh_getx")
(define getx
(lambda (win)
(getx-internal (window-c-pointer win))))
;;Fenstergr<67><72>e
(import-lambda-definition getmaxy-internal
(win)
"scsh_getmaxy")
(define getmaxy
(lambda (win)
(getmaxy-internal (window-c-pointer win))))
(import-lambda-definition getmaxx-internal
(win)
"scsh_getmaxx")
(define getmaxx
(lambda (win)
(getmaxx-internal (window-c-pointer win))))
;;eine Position zurueck
(define backspace
(lambda (win)
(let ((y (gety win))
(x (getx win))
(cols (getmaxx win)))
(if (and (= 0 y) (= 0 x))
(if (equal? #\space (winch win))
values
(begin
(wdelch win)
(wrefresh win)))
(if (= 0 x)
(begin
(wmove win y 0)
(wrefresh win)
(if (equal? #\space (winch win))
(begin
(wmove win (- y 1) (- cols 1))
(wdelch win)
(wrefresh win))
(begin
(wdelch win)
(wrefresh win))))
(begin
(wdelch win)
(wrefresh win)))))))
(define back
(lambda (win)
(let ((y (gety win))
(x (getx win))
(cols (getmaxx win)))
(if (and (= 0 y) (= 0 x))
values
(if (= 0 x)
(begin
(wmove win (- y 1) (- cols 1))
(wrefresh win))
(begin
(wmove win y (- x 1))
(wrefresh win)))))))