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

1462 lines
36 KiB
Scheme
Raw Normal View History

Add Christoph Hetz's all new, all singing, and all dancing input fields
2005-11-11 03:01:07 -05:00
;; TODOO
;; sobald funktinalität getestet
;; und abgesegnet ->
;; mach's klein! mach's schnell!...
;;===============================================================================
;; record input-field:
(define-record-type input-field :input-field
(really-make-input-field default-text
edit-lines
window
behavior
insert-active
x-loc y-loc
x-dim y-dim
x-pos y-pos
x-edit-pos y-edit-pos
x-offset y-offset
x-scroll y-scroll)
input-field?
(default-text if-default-text)
(edit-lines if-edit-lines set-if-edit-lines!)
(window if-window set-if-window!)
(behavior if-behavior set-if-behavior!)
(insert-active if-insert-active set-if-insert-active!)
(x-loc if-x-loc set-if-x-loc!)
(y-loc if-y-loc set-if-y-loc!)
(x-dim if-x-dim set-if-x-dim!)
(y-dim if-y-dim set-if-y-dim!)
(x-pos if-x-pos set-if-x-pos!)
(y-pos if-y-pos set-if-y-pos!)
(x-edit-pos if-x-edit-pos set-if-x-edit-pos!)
(y-edit-pos if-y-edit-pos set-if-y-edit-pos!)
(x-offset if-x-offset set-if-x-offset!)
(y-offset if-y-offset set-if-y-offset!)
(x-scroll if-x-scroll set-if-x-scroll!)
(y-scroll if-y-scroll set-if-y-scroll!))
(define-record-discloser :input-field
(lambda (i-f)
(list 'input-field
(if-default-text i-f))))
;; record input-field END
;;===============================================================================
;;===============================================================================
;; "basics"
; ----------------------------------------------------------------------------
;; "basics" - make-input-field
(define make-input-field
(lambda (x-dim y-dim . args)
(let* ((args-len (length args))
(default-text (if (> args-len 0)
(car args)
""))
(behavior (if (> args-len 1)
(cadr args)
standard-behavior))
(insert-active (if (> args-len 2)
(caddr args)
#t))
(x-scroll (if (> args-len 3)
(cadddr args)
#f))
(y-scroll (if (> args-len 4)
(caddddr args)
#f)))
(let ((i-f (really-make-input-field default-text
#f
#f
behavior
insert-active
#f #f
x-dim y-dim
0 0
0 0
0 0
x-scroll y-scroll)))
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
default-text))
i-f))))
;; "basics" - make-input-field END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; "basics" - remove / install-input-field & cursor-over-input-field?
;; FIXIT: sollte jemand auf die idee kommen ein input-field in mehrere
;; fenster zu installieren, müsste man hier noch was tun :-(
;; --------------------------------------------
;; input-field-lookup-list
;; für die zentrale verwaltung der input-fields
;; --------------------------------------------
(define input-fields-lookup-list '())
;; --------------------------------------------------
;; install-input-field ordnet einem input-field ein
;; window zu und trägt das input-field in die
;; look-up-liste als weak-pointer ein
;; ---------------------------------------------------
(define install-input-field
(lambda (i-f window x y)
(set-if-window! i-f window)
(set-if-y-loc! i-f y)
(set-if-x-loc! i-f x)
(set! input-fields-lookup-list
(cons (make-weak-pointer i-f)
(util-filter (lambda (x) x)
input-fields-lookup-list)))
(refresh-all i-f)
(wrefresh window)))
(define make&install-input-field
(lambda (win x-loc y-loc x-dim y-dim . args)
(install-input-field (apply make-input-field
x-dim y-dim
args)
win
x-loc y-loc)))
(define remove-input-field
(lambda (i-f)
(set! input-fields-lookup-list
(let loop ((input-fields input-fields-lookup-list))
(if (null? input-fields)
'()
(let ((first (car input-fields)))
(if (eq? i-f first)
(cdr input-fields)
(cons first
(loop (cdr input-fields))))))))))
;; --------------------------------------------------------
;; cursor-over-input-field? schaut nach, ob ein input-field
;; in das übergebene window eingetragen ist und ob
;; sich der cursor über diesem befindet
;; --------------------------------------------------------
(define cursor-over-input-field?
(lambda (window)
(let ((x (getx window))
(y (gety window)))
(let loop ((i-f-lst input-fields-lookup-list))
(if (null? i-f-lst)
#f
(let* ((i-f (weak-pointer-ref (car i-f-lst)))
(win (if i-f
(if-window i-f)
#f)))
(if (eq? window win)
(or (cursor-over-this-input-field? x y i-f)
(loop (cdr i-f-lst)))
(loop (cdr i-f-lst)))))))))
(define cursor-over-this-input-field?
(lambda (cursor-x cursor-y i-f)
(let* ((upper-left-x (if-x-loc i-f))
(upper-left-y (if-y-loc i-f))
(lower-right-x (- (+ upper-left-x
(if-x-dim i-f))
1))
(lower-right-y (- (+ upper-left-y
(if-y-dim i-f))
1)))
(if (and (>= cursor-y upper-left-y)
(<= cursor-y lower-right-y)
(>= cursor-x upper-left-x)
(<= cursor-x lower-right-x))
i-f
#f))))
;; "basics" - remove / install-input-field & cursor-over-input-field END
;; ---------------------------------------------------------------------------
;; ---------------------------------------------------------------------------
;; "basics" - selectors
;; TODOO - vielleicht gibt's sowas wie "export-as"
(define input-field-default-text if-default-text)
(define input-field-x-location if-x-loc)
(define input-field-y-location if-y-loc)
(define input-field-x-size if-x-dim)
(define input-field-y-size if-y-dim)
(define input-field-column if-x-edit-pos)
(define input-field-line if-y-edit-pos)
(define input-field-x-scroll if-x-scroll)
(define input-field-y-scroll if-y-scroll)
(define input-field-insert if-insert-active)
(define input-field-text
(lambda (i-f)
(list->string (cat (if-edit-lines i-f)))))
;(define input-field-edit-pos
; (lambda (i-f)
; (values (if-x-edit-pos i-f)
; (if-y-edit-pos i-f))))
;; "basics" - selectors END
;; ---------------------------------------------------------------------------
;; ---------------------------------------------------------------------------
;; "basics" - clear/reset
(define input-field-clear
(lambda (i-f)
(set-if-x-offset! i-f 0)
(set-if-y-offset! i-f 0)
(set-if-x-pos! i-f 0)
(set-if-y-pos! i-f 0)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(set-if-edit-lines! i-f '(()))
(refresh-all i-f)))
(define input-field-reset
(lambda (i-f)
(set-if-x-offset! i-f 0)
(set-if-y-offset! i-f 0)
(set-if-x-pos! i-f 0)
(set-if-y-pos! i-f 0)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
(if-default-text i-f)))
(refresh-all i-f)))
;; "basics" - clear/reset END
;; ---------------------------------------------------------------------------
;; "basics" END
;;===============================================================================
;;===============================================================================
;; draw/refresh functions
(define paint-black
(lambda (i-f)
(let ((x-dim (if-x-dim i-f))
(y-dim (if-y-dim i-f))
(x-loc (if-x-loc i-f))
(y-loc (if-y-loc i-f))
(win (if-window i-f)))
(let loop ((dy 0)
(strings (map list->string
(fill-up '()
y-dim
(fill-up '()
x-dim
#\space)))))
(if (null? strings)
#t
(begin
(mvwaddstr win
(+ y-loc dy) x-loc
(car strings))
(loop (+ dy 1)
(cdr strings))))))))
;;; TODOOOO (performance):
;;; funktionen geben zurück welcher
;;; refresh notwendig ist z.b.:
;;; 'position
;;; 'current-line
;;; 'from-current-line ...
;;; if-refresh ruft dann das richtige auf
(define if-refresh
(lambda (i-f msg)
(if msg
(refresh-all i-f)
(values #t #f))))
(define refresh-position
(lambda (i-f)
(wmove (if-window i-f)
(+ (if-y-loc i-f)
(if-y-pos i-f))
(+ (if-x-loc i-f)
(if-x-pos i-f)))
(values #t #t)))
(define refresh-from-position
(lambda (i-f)
#f))
(define refresh-all
(lambda (i-f)
(let ((x-loc (if-x-loc i-f))
(y-loc (if-y-loc i-f))
(x-dim (if-x-dim i-f))
(y-dim (if-y-dim i-f))
(x-offset (if-x-offset i-f))
(y-offset (if-y-offset i-f))
(win (if-window i-f)))
(let* ((if-lines (map (lambda (if-line)
(util-filter (lambda (char)
(not (char=? char #\newline)))
if-line))
(cat (map (lambda (edit-line)
(edit-line->if-lines i-f
edit-line))
(if-edit-lines i-f)))))
(if-lines-cut (take (drop (map (lambda (if-line)
(take (drop if-line
x-offset)
x-dim))
if-lines)
y-offset)
y-dim))
(if-lines-filled (map (lambda (if-line)
(fill-up if-line
x-dim
#\space))
(fill-up if-lines-cut
y-dim
'()))))
(let loop ((lines if-lines-filled)
(y-ofst 0))
(if (null? lines)
(refresh-position i-f)
(begin
(mvwaddstr win
(+ y-loc y-ofst)
x-loc
(list->string (car lines)))
(loop (cdr lines)
(+ y-ofst 1)))))))))
(define refresh-current-line
(lambda (i-f)
#f))
;; draw/refresh functions END
;;===============================================================================
;;===============================================================================
;; send-input-field
(define send-input-field
(lambda (i-f msg . args)
(if (integer? msg)
(cond ((get-behavior i-f msg) =>
(lambda (method)
(apply really-send-input-field i-f method args)))
(else (apply really-send-input-field i-f msg args)))
(values #f #f))))
(define really-send-input-field
(lambda (i-f msg . args)
(cond ((and (number? msg)
(or (and (> msg 31)
(< msg 127))
(= msg 10)
(= msg 13)))
(if-refresh i-f (insert-char i-f
(if (= msg 13)
#\newline
(ascii->char msg)))))
((eq? msg 'move-prev-line)
(if-refresh i-f (move-prev-line i-f)))
((eq? msg 'move-next-line)
(if-refresh i-f (move-next-line i-f)))
((eq? msg 'move-left)
(if-refresh i-f (move-left i-f)))
((eq? msg 'move-right)
(if-refresh i-f (move-right i-f)))
((eq? msg 'delete-right)
(if-refresh i-f (delete-right i-f)))
((eq? msg 'move-forward)
(if-refresh i-f (move-forward i-f)))
((eq? msg 'move-backward)
(if-refresh i-f (move-backward i-f)))
((eq? msg 'delete-left)
(if-refresh i-f (delete-left i-f)))
((eq? msg 'delete-all-right)
(if-refresh i-f (delete-all-right i-f)))
((eq? msg 'delete-all-left)
(if-refresh i-f (delete-all-left i-f)))
((eq? msg 'delete-line)
(if-refresh i-f (delete-line i-f)))
((eq? msg 'goto-begin-of-line)
(if-refresh i-f (goto-begin-of-line i-f)))
((eq? msg 'goto-end-of-line)
(if-refresh i-f (goto-end-of-line i-f)))
((eq? msg 'goto-begin-of-first-line)
(if-refresh i-f (goto-begin-of-first-line i-f)))
((eq? msg 'goto-begin-of-last-line)
(if-refresh i-f (goto-begin-of-last-line i-f)))
((eq? msg 'goto-begin-of-word-forward)
(if-refresh i-f (goto-begin-of-word-forward i-f)))
((eq? msg 'goto-begin-of-word-backward)
(if-refresh i-f (goto-begin-of-word-backward i-f)))
((eq? msg 'goto-end-of-word-forward)
(if-refresh i-f (goto-begin-of-word-forward i-f)))
((eq? msg 'goto-end-of-word-backward)
(if-refresh i-f (goto-begin-of-word-backward i-f)))
; ((eq? msg 'input-field-move-up)
; (if-refresh i-f (input-field-move-up i-f)))
; ((eq? msg 'input-field-move-down)
; (if-refresh i-f (input-field-move-down i-f)))
; ((eq? msg 'input-field-move-left)
; (if-refresh i-f (input-field-move-left i-f)))
; ((eq? msg 'input-field-move-right)
; (if-refresh i-f (input-field-move-right i-f)))
((eq? msg 'refresh-all)
(refresh-all i-f))
((eq? msg 'toggle-insert)
(toggle-insert i-f))
((eq? msg 'restore)
(restore-input-field i-f))
((list? msg)
(for-each (lambda (msg-single)
(send-input-field i-f
msg-single))
msg)
(values #t #t))
(else (values #f #f)))))
;; send-input-field END
;;===============================================================================
;;===============================================================================
;; behavior lists
(define standard-behavior
(list (cons key-up
'move-prev-line)
(cons key-down
'move-next-line)
(cons key-left
'move-left)
(cons key-right
'move-right)
(cons key-backspace
'delete-left)
(cons key-dc
'delete-right)
(cons key-home
'goto-begin-of-line)
(cons key-end
'goto-end-of-line)))
(define standard-behavior-pro
(append standard-behavior
(list (cons 2 ;; C-b
'move-left)
(cons 6 ;; C-f
'move-right)
(cons 16 ;; C-p
'move-prev-line)
(cons 14 ;; C-n
'move-next-line)
(cons 1 ;; C-a
'goto-begin-of-line)
(cons 5 ;; C-e
'goto-end-of-line)
(cons 4 ;; C-d
'delete-right)
(cons 11 ;; C-k
'delete-all-right))))
;; behavior lists END
;;===============================================================================
;;===============================================================================
;; behavior methods
(define get-behavior
(lambda (i-f msg)
(let loop ((behavior (if-behavior i-f)))
(if (null? behavior)
#f
(if (eq? msg (caar behavior))
(cdar behavior)
(loop (cdr behavior)))))))
;; ----------------------------------------------------------------------------
;; move
(define move-prev-line
(lambda (i-f)
(if (first-line? i-f)
#f
(begin
(set-if-y-edit-pos! i-f (- (if-y-edit-pos i-f)
1))
(sync-if-edit-pos i-f)))))
(define move-next-line
(lambda (i-f)
(if (last-line? i-f)
#f
(begin
(set-if-y-edit-pos! i-f (+ (if-y-edit-pos i-f)
1))
(sync-if-edit-pos i-f)))))
(define move-left
(lambda (i-f)
(if (begin-of-line? i-f)
#f
(begin
(set-if-x-edit-pos! i-f (- (if-x-edit-pos i-f)
1))
(sync-if-edit-pos i-f)))))
(define move-right
(lambda (i-f)
(if (or (end-of-line? i-f)
(and (right-border? i-f)
(lower-border? i-f)
(not (if-y-scroll i-f))
(not (if-x-scroll i-f))))
#f
(begin
(set-if-x-edit-pos! i-f (+ (if-x-edit-pos i-f)
1))
(sync-if-edit-pos i-f)))))
(define move-forward
(lambda (i-f)
(if (move-right i-f)
#t
(if (move-next-line i-f)
(goto-begin-of-line i-f)
#f))))
(define move-backward
(lambda (i-f)
(if (move-left i-f)
#t
(if (move-prev-line i-f)
(goto-end-of-line i-f)
#f))))
(define sync-if-edit-pos
(lambda (i-f)
(call-with-values
(lambda ()
(edit-pos->if-pos i-f
(if-x-edit-pos i-f)
(if-y-edit-pos i-f)))
(lambda (x-pos y-pos)
(set-if-x-pos! i-f (- x-pos (if-x-offset i-f)))
(set-if-y-pos! i-f (- y-pos (if-y-offset i-f)))))
(legalize-position i-f)
(if (not (legal-offsets? i-f))
(legalize-offsets i-f)
#t)))
;; move END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; scroll
(define scroll-up
(lambda (i-f)
(set-if-y-offset! i-f
(- (if-y-offset i-f)
1))
#t))
(define scroll-down
(lambda (i-f)
(set-if-y-offset! i-f
(+ (if-y-offset i-f)
1))
#t))
(define scroll-left
(lambda (i-f)
(set-if-x-offset! i-f
(- (if-x-offset i-f)
1))
#t))
(define scroll-right
(lambda (i-f)
(set-if-x-offset! i-f
(+ (if-x-offset i-f)
1))
#t))
;; scroll END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; insert
(define insert-char
(lambda (i-f char)
(let* ((y-edit-pos (if-y-edit-pos i-f))
(edit-lines (if-edit-lines i-f))
(current-line (list-ref edit-lines
y-edit-pos))
(new-lines-tmp (string->edit-lines
(list->string
((if (or (char=? char #\newline)
(if-insert-active i-f))
insert
replace)
current-line
(if-x-edit-pos i-f)
char))))
(new-lines (if (and (= (+ y-edit-pos 1)
(length edit-lines))
(end-of-line? i-f)
(char=? char #\newline))
(append new-lines-tmp '(()))
new-lines-tmp))
(new-edit-lines (append (take edit-lines
y-edit-pos)
new-lines
(drop edit-lines
(+ y-edit-pos 1)))))
(if (or (if-y-scroll i-f)
(= (length (edit-lines->if-lines i-f new-lines))
(length (edit-line->if-lines i-f current-line)))
(<= (length (edit-lines->if-lines i-f new-edit-lines))
(if-y-dim i-f)))
(begin (set-if-edit-lines! i-f new-edit-lines)
(if (char=? char #\newline)
(begin (set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f (+ (if-y-edit-pos i-f)
1))
(sync-if-edit-pos i-f))
(move-right i-f))
#t)
#f))))
;; insert END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; delete
(define delete-right
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(edit-lines (if-edit-lines i-f))
(current-line (list-ref edit-lines
y-edit-pos))
(current-line-len (length current-line)))
(if (and (< x-edit-pos current-line-len)
(not (char=? (list-ref current-line
x-edit-pos)
#\newline)))
(let ((new-line (remove current-line
x-edit-pos)))
(set-if-edit-lines! i-f (replace edit-lines
y-edit-pos
new-line))
#t)
#f))))
(define delete-left
(lambda (i-f)
(if (move-left i-f)
(delete-right i-f)
#f)))
(define delete-all-left
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(edit-lines (if-edit-lines i-f))
(current-line (list-ref edit-lines
y-edit-pos)))
(if (not (zero? x-edit-pos))
(begin
(set-if-edit-lines! i-f (replace edit-lines
y-edit-pos
(drop current-line
x-edit-pos)))
(set-if-x-edit-pos! i-f 0)
(sync-if-edit-pos i-f)
#t)
#f))))
(define delete-all-right
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(edit-lines (if-edit-lines i-f))
(current-line (list-ref edit-lines
y-edit-pos)))
(if (and (end-of-line? i-f)
(not (last-line? i-f)))
(begin
(set-if-edit-lines! i-f
(append (take edit-lines
y-edit-pos)
(list
(append
(reverse (cdr (reverse current-line)))
(list-ref edit-lines
(+ y-edit-pos 1))))
(drop edit-lines
(+ y-edit-pos 2))))
#t)
(begin
(set-if-edit-lines! i-f
(replace edit-lines
y-edit-pos
(let ((new-line (take current-line
x-edit-pos)))
(if (char=? (last current-line)
#\newline)
(append new-line
(list #\newline))
new-line))))
#t)))))
(define delete-line
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(edit-lines (if-edit-lines i-f))
(edit-lines-len (length edit-lines))
(current-line (list-ref edit-lines
y-edit-pos)))
(if (= edit-lines-len 1)
(begin
(set-if-edit-lines! i-f '(()))
(set-if-x-edit-pos! i-f 0)
(sync-if-edit-pos i-f))
(begin
(set-if-edit-lines! i-f (remove edit-lines
y-edit-pos))
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f (min y-edit-pos
(- edit-lines-len 2)))
(sync-if-edit-pos i-f))))))
;; delete END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; goto
;; TODOO - fertig machen... (siehe #f)
(define goto-begin-of-word-forward
(lambda (i-f)
(goto-next-forward i-f #\space #\newline)
(goto-next-not-forward i-f #\space #\newline)
#t))
(define goto-end-of-word-forward
(lambda (i-f)
#f))
(define goto-begin-of-word-backward
(lambda (i-f)
(if (and (goto-next-not-backward i-f #\space #\newline)
(goto-next-backward i-f #\space #\newline))
(move-forward i-f))
#t))
(define goto-end-of-word-backward
(lambda (i-f)
#f))
(define goto-begin-of-line
(lambda (i-f)
(set-if-x-edit-pos! i-f 0)
(sync-if-edit-pos i-f)))
(define goto-end-of-line
(lambda (i-f)
(let ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f)))
(call-with-values
(lambda ()
(let* ((current-line (list-ref (if-edit-lines i-f)
y-edit-pos)))
(if (null? current-line)
(set-if-x-edit-pos! i-f 0)
(let ((len (length current-line))
(end-char (last current-line)))
(set-if-x-edit-pos! i-f (if (char=? end-char #\newline)
(- len 1)
len))))
(edit-pos->if-pos i-f
(if-x-edit-pos i-f)
y-edit-pos)))
(lambda (x-pos y-pos)
(set-if-x-pos! i-f (- x-pos (if-x-offset i-f)))
(set-if-y-pos! i-f (- y-pos (if-y-offset i-f)))
(sync-if-edit-pos i-f))))))
(define goto-begin-of-first-line
(lambda (i-f)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(sync-if-edit-pos i-f)))
(define goto-end-of-first-line
(lambda (i-f)
#f))
(define goto-begin-of-last-line
(lambda (i-f)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f (- (length (if-edit-lines i-f))
1))
(sync-if-edit-pos i-f)))
(define goto-end-of-last-line
(lambda (i-f)
#f))
;; ------------------------------------------------------------------
; wozu eigentlich?
;(define goto-end-of-if-line
; (lambda (i-f)
; #f))
;; ------------------------------------------------------------------
(define goto-next-forward
(lambda (i-f . chars)
(if (move-forward i-f)
(let loop ()
(let ((sign (sign-under-cursor i-f)))
(if (and sign
(memq sign chars))
#t
(if (move-forward i-f)
(loop)
#f))))
#f)))
(define goto-next-not-forward
(lambda (i-f . chars)
(if (move-forward i-f)
(let loop ()
(let ((sign (sign-under-cursor i-f)))
(if (and sign
(not (memq sign chars)))
#t
(if (move-forward i-f)
(loop)
#f))))
#f)))
(define goto-next-backward
(lambda (i-f . chars)
(if (move-backward i-f)
(let loop ()
(let ((sign (sign-under-cursor i-f)))
(if (and sign
(memq sign chars))
#t
(if (move-backward i-f)
(loop)
#f))))
#f)))
(define goto-next-not-backward
(lambda (i-f . chars)
(if (move-backward i-f)
(let loop ()
(let ((sign (sign-under-cursor i-f)))
(if (and sign
(not (memq sign chars)))
#t
(if (move-backward i-f)
(loop)
#f))))
#f)))
;; goto END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; others
(define toggle-insert
(lambda (i-f)
(set-if-insert-active! i-f
(not (if-insert-active i-f)))
(values #t #f)))
;; others END
;; ----------------------------------------------------------------------------
;; behavior methods END
;;===============================================================================
;;===============================================================================
;; "mutate" functions and few others
(define input-field-refresh
(lambda (i-f)
(really-send-input-field i-f 'refresh-all)))
;(define input-field-move-up
; (lambda (i-f)
; (let ((y-loc (if-y-loc i-f)))
; (if (> y-loc 1)
; (begin
; (paint-black i-f)
; (set-if-y-loc! i-f (- y-loc
; 1))
; #t)
; #f))))
;(define input-field-move-down
; (lambda (i-f)
; (let ((y-loc (if-y-loc i-f)))
; (if (< (+ y-loc (if-y-dim i-f))
; (- (getmaxy (if-window i-f))
; 1))
; (begin
; (paint-black i-f)
; (set-if-y-loc! i-f (+ y-loc
; 1))
; #t)
; #f))))
;(define input-field-move-left
; (lambda (i-f)
; (let ((x-loc (if-x-loc i-f)))
; (if (> x-loc 1)
; (begin
; (paint-black i-f)
; (set-if-x-loc! i-f (- x-loc
; 1))
; #t)
; #f))))
;(define input-field-move-right
; (lambda (i-f)
; (let ((x-loc (if-x-loc i-f)))
; (if (< (+ x-loc (if-x-dim i-f))
; (- (getmaxx (if-window i-f))
; 1))
; (begin
; (paint-black i-f)
; (set-if-x-loc! i-f (+ x-loc
; 1))
; #t)
; #f))))
(define input-field-move
(lambda (i-f x y)
(let ((win (if-window i-f)))
(if (and (> x 1)
(> y 1)
(< (+ x (if-x-dim i-f))
(getmaxx win))
(< (+ y (if-y-dim i-f))
(getmaxy win)))
(begin
(paint-black i-f)
(set-if-x-loc! i-f x)
(set-if-y-loc! i-f y)
(refresh-all i-f))
#f))))
(define input-field-resize
(lambda (i-f x y)
(let ((win (if-window i-f)))
(if (and (> x 0)
(> y 0)
(< (+ x (if-x-loc i-f))
(getmaxx win))
(< (+ y (if-y-loc i-f))
(getmaxy win)))
(begin
(paint-black i-f)
(set-if-x-offset! i-f 0)
(set-if-y-offset! i-f 0)
(set-if-x-pos! i-f 0)
(set-if-y-pos! i-f 0)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(set-if-x-dim! i-f x)
(set-if-y-dim! i-f y)
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
(input-field-text i-f)))
(refresh-all i-f))
#f))))
(define input-field-toggle-x-scroll
(lambda (i-f)
(paint-black i-f)
(set-if-x-offset! i-f 0)
(set-if-y-offset! i-f 0)
(set-if-x-pos! i-f 0)
(set-if-y-pos! i-f 0)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(set-if-x-scroll! i-f (not (if-x-scroll i-f)))
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
(input-field-text i-f)))
(refresh-all i-f)))
(define input-field-toggle-y-scroll
(lambda (i-f)
(paint-black i-f)
(set-if-x-offset! i-f 0)
(set-if-y-offset! i-f 0)
(set-if-x-pos! i-f 0)
(set-if-y-pos! i-f 0)
(set-if-x-edit-pos! i-f 0)
(set-if-y-edit-pos! i-f 0)
(set-if-y-scroll! i-f (not (if-y-scroll i-f)))
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
(input-field-text i-f)))
(refresh-all i-f)))
(define restore-input-field
(lambda (i-f)
(set-if-edit-lines! i-f
(string->if-edit-lines i-f
(input-field-text i-f)))
(sync-if-edit-pos i-f)
(refresh-all i-f)))
;; mutate-functions END
;;===============================================================================
;;===============================================================================
;; helpfunctions (converter, predicates...)
(define string->edit-lines
(lambda (str)
(let loop ((chars (string->list str)))
(if (null? chars)
'()
(call-with-values
(lambda ()
(split-after-first-newline chars))
(lambda (line chars)
(cons line
(loop chars))))))))
(define string->edit-lines-with-null
(lambda (str)
(let* ((edit-lines (let loop ((chars (string->list str)))
(if (null? chars)
'()
(call-with-values
(lambda ()
(split-after-first-newline chars))
(lambda (line chars)
(cons line
(loop chars)))))))
(last-line (if (null? edit-lines)
#f
(last edit-lines))))
(if (and last-line
(not (null? last-line))
(char=? (last last-line)
#\newline))
(append edit-lines '(()))
edit-lines))))
(define split-after-first-newline
(lambda (chars)
(let loop ((line '())
(chars chars))
(if (null? chars)
(values (reverse line) chars)
(let ((char (car chars))
(rest (cdr chars)))
(if (char=? char #\newline)
(values (reverse (cons char line))
rest)
(loop (cons char line)
rest)))))))
(define edit-line->if-lines
(lambda (i-f edit-line)
(let ((x-dim (if-x-dim i-f))
(x-scroll (if-x-scroll i-f)))
(if (or x-scroll
(null? edit-line))
(list edit-line)
(let loop ((edit-line edit-line))
(if (null? edit-line)
'()
(call-with-values
(lambda ()
(split-if-line-from-edit-line x-dim edit-line))
(lambda (if-line edit-line)
(cons if-line
(loop edit-line))))))))))
(define edit-lines->if-lines
(lambda (i-f edit-lines)
(cat (map (lambda (edit-line)
(edit-line->if-lines i-f edit-line))
edit-lines))))
(define split-if-line-from-edit-line
(lambda (x-dim edit-line)
(let loop ((if-line '())
(rest edit-line)
(space-left x-dim))
(if (null? rest)
(values (reverse if-line)
rest)
(let ((char (car rest)))
(cond ((char=? char #\newline)
(values (reverse (cons char
if-line))
(cdr rest)))
((zero? space-left)
(values (reverse if-line)
rest))
(else
(loop (cons char if-line)
(cdr rest)
(- space-left 1)))))))))
(define if-lines->edit-lines
(lambda (if-lines)
(let loop ((rest if-lines))
(if (null? rest)
'()
(call-with-values
(lambda ()
(split-edit-line-from-if-lines rest))
(lambda (edit-line rest)
(cons edit-line
(loop rest))))))))
(define split-edit-line-from-if-lines
(lambda (if-lines)
(let loop ((edit-line '())
(rest if-lines))
(if (null? rest)
(values (reverse edit-line) '())
(let ((rev-line (reverse (car rest))))
(if (null? rev-line)
(values '() (cdr rest))
(if (char=? (car rev-line)
#\newline)
(values (reverse (append rev-line
edit-line))
(cdr rest))
(loop (append rev-line
edit-line)
(cdr rest)))))))))
(define string->if-edit-lines
(lambda (i-f string)
(let* ((edit-lines (string->edit-lines-with-null string))
(if-lines (edit-lines->if-lines i-f edit-lines))
(if-lines-cut (if (if-y-scroll i-f)
if-lines
(take if-lines
(if-y-dim i-f)))))
(if-lines->edit-lines if-lines-cut))))
(define if->edit-pos
(lambda (i-f)
(let ((x-pos (+ (if-x-offset i-f)
(if-x-pos i-f)))
(y-pos (+ (if-y-offset i-f)
(if-y-pos i-f)))
(x-scroll (if-x-scroll i-f)))
(if x-scroll
(values x-pos y-pos)
(let loop ((edit-lines (if-edit-lines i-f))
(y-edit-pos 0)
(y-pos y-pos))
(if (null? edit-lines)
(let ((y-edit-pos (- y-edit-pos 1)))
(values (length (list-ref (if-edit-lines i-f)
y-edit-pos))
y-edit-pos))
(let* ((edit-line (car edit-lines))
(num-if-lines (length
(edit-line->if-lines i-f edit-line))))
(if (< y-pos num-if-lines)
(values (+ (* y-pos
(if-x-dim i-f))
x-pos)
y-edit-pos)
(loop (cdr edit-lines)
(+ y-edit-pos 1)
(- y-pos num-if-lines))))))))))
(define edit-pos->if-pos
(lambda (i-f x-edit-pos y-edit-pos)
(if (if-x-scroll i-f)
(values x-edit-pos y-edit-pos)
(let loop ((edit-lines (if-edit-lines i-f))
(y-edit-pos y-edit-pos)
(y-pos 0))
(if (null? edit-lines)
'error--edit-pos->if-pos
(if (zero? y-edit-pos)
(let ((x-dim (if-x-dim i-f)))
(values (modulo x-edit-pos
x-dim)
(+ y-pos
(quotient x-edit-pos
x-dim))))
(loop (cdr edit-lines)
(- y-edit-pos 1)
(+ y-pos
(length
(edit-line->if-lines i-f
(car edit-lines)))))))))))
;; ----------------------------------------------------------------------------
;; legalize-position
(define legalize-position
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(current-line (list-ref (if-edit-lines i-f)
y-edit-pos))
(current-line-len (length current-line)))
(if (or (> x-edit-pos current-line-len)
(and (> current-line-len 0)
(= x-edit-pos current-line-len)
(char=? (last current-line)
#\newline)))
(goto-end-of-line i-f)))
#t))
(define legal-offsets?
(lambda (i-f)
(let ((x (if-x-pos i-f))
(y (if-y-pos i-f)))
(and (>= x 0)
(< x (if-x-dim i-f))
(>= y 0)
(< y (if-y-dim i-f))))))
(define legalize-offsets
(lambda (i-f)
(let ((x-pos (if-x-pos i-f))
(x-offset (if-x-offset i-f))
(x-dim (if-x-dim i-f))
(y-pos (if-y-pos i-f))
(y-offset (if-y-offset i-f))
(y-dim (if-y-dim i-f)))
(if (< x-pos 0)
(begin
(set! x-offset (+ x-offset x-pos))
(set! x-pos 0)))
(if (> (+ x-pos 1)
x-dim)
(let ((dx (- (+ x-pos 1)
x-dim)))
(set! x-offset (+ x-offset dx))
(set! x-pos (- x-pos dx))))
(if (< y-pos 0)
(begin
(set! y-offset (+ y-offset y-pos))
(set! y-pos 0)))
(if (> (+ y-pos 1)
y-dim)
(let ((dy (- (+ y-pos 1)
y-dim)))
(set! y-offset (+ y-offset dy))
(set! y-pos (- y-pos dy))))
(set-if-x-pos! i-f x-pos)
(set-if-x-offset! i-f x-offset)
(set-if-y-pos! i-f y-pos)
(set-if-y-offset! i-f y-offset)
#t)))
;; legalize-position END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; predicates
(define first-line?
(lambda (i-f)
(zero? (if-y-edit-pos i-f))))
(define last-line?
(lambda (i-f)
(= (+ (if-y-edit-pos i-f)
1)
(length (if-edit-lines i-f)))))
(define begin-of-line?
(lambda (i-f)
(zero? (if-x-edit-pos i-f))))
(define end-of-line?
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(edit-line (list-ref (if-edit-lines i-f)
y-edit-pos)))
(or (= x-edit-pos
(length edit-line))
(char=? (list-ref edit-line
x-edit-pos)
#\newline)))))
(define left-border?
(lambda (i-f)
(= (if-x-pos i-f)
0)))
(define right-border?
(lambda (i-f)
(= (if-x-pos i-f)
(- (if-x-dim i-f) 1))))
(define lower-border?
(lambda (i-f)
(= (if-y-pos i-f)
(- (if-y-dim i-f) 1))))
(define upper-border?
(lambda (i-f)
(= (if-y-pos i-f)
0)))
;; predicates END
;; ----------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; selectors
(define sign-at-xy
(lambda (i-f x y)
#f))
(define sign-under-cursor
(lambda (i-f)
(let* ((x-edit-pos (if-x-edit-pos i-f))
(y-edit-pos (if-y-edit-pos i-f))
(current-line (list-ref (if-edit-lines i-f)
y-edit-pos))
(current-line-len (length current-line)))
(if (< x-edit-pos current-line-len)
(list-ref current-line x-edit-pos)
#f))))
(define sign-before-cursor
(lambda (i-f)
#f))
(define sign-behind-cursor
(lambda (i-f)
#f))
;; selectors END
;; ----------------------------------------------------------------------------
;; helpfunctions END
;;===============================================================================
;;===============================================================================
;; "primitives"
(define caddddr
(lambda (x)
(car (cddddr x))))
(define last
(lambda (lst)
(if (null? lst)
'error--last
(car (reverse lst)))))
(define fill-up
(lambda (lst len elem)
(append lst
(let loop ((n (- len
(length lst))))
(if (< n 0)
'error--fill-up
(if (zero? n)
'()
(cons elem
(loop (- n 1)))))))))
(define cat
(lambda (lst-lst)
(if (null? lst-lst)
'()
(append (car lst-lst)
(cat (cdr lst-lst))))))
(define split
(lambda (lst n)
(let loop ((fst '())
(scnd lst)
(n n))
(if (or (null? scnd)
(zero? n))
(values (reverse fst) scnd)
(loop (cons (car scnd)
fst)
(cdr scnd)
(- n 1))))))
(define remove
(lambda (lst pos)
(append (take lst pos)
(drop lst (+ pos 1)))))
(define insert
(lambda (lst n elem)
(if (zero? n)
(cons elem lst)
(cons (car lst)
(insert (cdr lst)
(- n 1)
elem)))))
(define replace
(lambda (lst n elem)
(if (zero? n)
(cons elem
(if (null? lst)
lst
(cdr lst)))
(cons (car lst)
(replace (cdr lst)
(- n 1)
elem)))))
(define take
(lambda (lst n)
(if (or (null? lst)
(zero? n))
'()
(cons (car lst)
(take (cdr lst)
(- n 1))))))
(define drop
(lambda (lst n)
(if (or (null? lst)
(zero? n))
lst
(drop (cdr lst)
(- n 1)))))
;; "primitives" END
;;===============================================================================