1620 lines
48 KiB
Scheme
1620 lines
48 KiB
Scheme
|
|
|
|
;;===============================================================================
|
|
;; exeptions
|
|
|
|
(define-condition-type 'buffer-full '(error))
|
|
(define buffer-full? (condition-predicate 'buffer-full))
|
|
|
|
;; exeptions END
|
|
;;===============================================================================
|
|
|
|
|
|
;;===============================================================================
|
|
;; record input-field:
|
|
|
|
(define-record-type input-field :input-field
|
|
(really-make-input-field prompt
|
|
default-text
|
|
edit-lines
|
|
window
|
|
behavior
|
|
insert-active
|
|
x-loc y-loc ;; position of INPUT-FIELD
|
|
x-dim y-dim ;; size of INPUT-FIELD
|
|
x-pos y-pos ;; cursor position in INPUT-FIELD
|
|
x-edit-pos y-edit-pos ;; cursor position in edit-lines (text-buffer)
|
|
x-offset y-offset ;; what snippet of the edit-lines are shown in I_F
|
|
x-scroll y-scroll) ;; which direction is allowed to be scrolled
|
|
input-field?
|
|
(prompt input-field-prompt set-input-field-prompt!)
|
|
(default-text input-field-default-text)
|
|
(edit-lines input-field-edit-lines set-input-field-edit-lines!)
|
|
(window input-field-window set-input-field-window!)
|
|
(behavior input-field-behavior set-input-field-behavior!)
|
|
(insert-active input-field-insert-active set-input-field-insert-active!)
|
|
(x-loc input-field-x-loc set-input-field-x-loc!)
|
|
(y-loc input-field-y-loc set-input-field-y-loc!)
|
|
(x-dim input-field-x-dim set-input-field-x-dim!)
|
|
(y-dim input-field-y-dim set-input-field-y-dim!)
|
|
(x-pos input-field-x-pos set-input-field-x-pos!)
|
|
(y-pos input-field-y-pos set-input-field-y-pos!)
|
|
(x-edit-pos input-field-x-edit-pos set-input-field-x-edit-pos!)
|
|
(y-edit-pos input-field-y-edit-pos set-input-field-y-edit-pos!)
|
|
(x-offset input-field-x-offset set-input-field-x-offset!)
|
|
(y-offset input-field-y-offset set-input-field-y-offset!)
|
|
(x-scroll input-field-x-scroll set-input-field-x-scroll!)
|
|
(y-scroll input-field-y-scroll set-input-field-y-scroll!))
|
|
|
|
(define-record-discloser :input-field
|
|
(lambda (input-field)
|
|
(list 'input-field
|
|
(input-field-default-text input-field))))
|
|
|
|
(define input-field-init-text
|
|
(lambda (input-field)
|
|
(let ((prompt (input-field-prompt input-field)))
|
|
(if prompt
|
|
(string-append prompt
|
|
(input-field-default-text input-field))
|
|
(input-field-default-text input-field)))))
|
|
|
|
;; record input-field END
|
|
;;===============================================================================
|
|
|
|
;;===============================================================================
|
|
;; "basics"
|
|
|
|
; ----------------------------------------------------------------------------
|
|
;; "basics" - make-input-field
|
|
|
|
(define make-input-field
|
|
(lambda (x-dim y-dim . args)
|
|
(let* ((args-len (length args))
|
|
(prompt (if (> args-len 0)
|
|
(car args)
|
|
#f))
|
|
(prompt-length (if prompt
|
|
(string-length prompt)
|
|
0))
|
|
(default-text (if (> args-len 1)
|
|
(cadr args)
|
|
""))
|
|
(behavior (if (> args-len 2)
|
|
(caddr args)
|
|
standard-behavior))
|
|
(insert-active (if (> args-len 3)
|
|
(cadddr args)
|
|
#t))
|
|
(x-scroll (if (> args-len 4)
|
|
(caddddr args)
|
|
#f))
|
|
(y-scroll (if (> args-len 5)
|
|
(cadddddr args)
|
|
#f)))
|
|
(let ((input-field (really-make-input-field prompt
|
|
default-text
|
|
#f
|
|
#f
|
|
behavior
|
|
insert-active
|
|
#f #f
|
|
x-dim y-dim
|
|
prompt-length 0
|
|
prompt-length 0
|
|
0 0
|
|
x-scroll y-scroll)))
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-init-text input-field)))
|
|
input-field))))
|
|
|
|
;; "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 (input-field window x y)
|
|
(set-input-field-window! input-field window)
|
|
(set-input-field-y-loc! input-field y)
|
|
(set-input-field-x-loc! input-field x)
|
|
(set! input-fields-lookup-list
|
|
(cons (make-weak-pointer input-field)
|
|
(util-filter (lambda (x) x)
|
|
input-fields-lookup-list)))))
|
|
|
|
(define make&install-input-field
|
|
(lambda (win x-loc y-loc x-dim y-dim . args)
|
|
(let ((input-field (apply make-input-field
|
|
x-dim y-dim
|
|
args)))
|
|
(install-input-field input-field
|
|
win
|
|
x-loc y-loc)
|
|
input-field)))
|
|
|
|
(define remove-input-field
|
|
(lambda (input-field)
|
|
(set! input-fields-lookup-list
|
|
(let loop ((input-fields input-fields-lookup-list))
|
|
(if (null? input-fields)
|
|
'()
|
|
(let ((first (car input-fields)))
|
|
(if (eq? input-field 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 ((input-field-lst input-fields-lookup-list))
|
|
(if (null? input-field-lst)
|
|
#f
|
|
(let* ((input-field (weak-pointer-ref (car input-field-lst)))
|
|
(win (if input-field
|
|
(input-field-window input-field)
|
|
#f)))
|
|
(if (eq? window win)
|
|
(or (cursor-over-this-input-field? x y input-field)
|
|
(loop (cdr input-field-lst)))
|
|
(loop (cdr input-field-lst)))))))))
|
|
|
|
(define cursor-over-this-input-field?
|
|
(lambda (cursor-x cursor-y input-field)
|
|
(let* ((upper-left-x (input-field-x-loc input-field))
|
|
(upper-left-y (input-field-y-loc input-field))
|
|
(lower-right-x (- (+ upper-left-x
|
|
(input-field-x-dim input-field))
|
|
1))
|
|
(lower-right-y (- (+ upper-left-y
|
|
(input-field-y-dim input-field))
|
|
1)))
|
|
(if (and (>= cursor-y upper-left-y)
|
|
(<= cursor-y lower-right-y)
|
|
(>= cursor-x upper-left-x)
|
|
(<= cursor-x lower-right-x))
|
|
input-field
|
|
#f))))
|
|
;; "basics" - remove / install-input-field & cursor-over-input-field END
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; "basics" - selectors
|
|
|
|
;; TODOO - besser mit "export-as"... oder wie das heißt
|
|
(define input-field-default-text input-field-default-text)
|
|
(define input-field-x-location input-field-x-loc)
|
|
(define input-field-y-location input-field-y-loc)
|
|
(define input-field-x-size input-field-x-dim)
|
|
(define input-field-y-size input-field-y-dim)
|
|
(define input-field-column input-field-x-edit-pos)
|
|
(define input-field-line input-field-y-edit-pos)
|
|
(define input-field-x-scroll input-field-x-scroll)
|
|
(define input-field-y-scroll input-field-y-scroll)
|
|
(define input-field-insert input-field-insert-active)
|
|
|
|
(define input-field-text
|
|
(lambda (input-field)
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(lst (cat (input-field-edit-lines input-field))))
|
|
(list->string (if prompt
|
|
(drop lst (string-length prompt))
|
|
lst)))))
|
|
|
|
(define set-input-field-text!
|
|
(lambda (input-field text)
|
|
(goto-begin-of-line input-field)
|
|
(set-input-field-edit-lines! input-field
|
|
(string->input-field-edit-lines
|
|
input-field
|
|
(let ((prompt (input-field-prompt input-field)))
|
|
(if prompt
|
|
(string-append prompt
|
|
text)
|
|
text))))
|
|
(goto-end-of-last-line input-field)))
|
|
|
|
|
|
|
|
(define input-field-text-wp
|
|
(lambda (input-field)
|
|
(list->string (cat (input-field-edit-lines input-field)))))
|
|
|
|
|
|
;; "basics" - selectors END
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; "basics" - clear/reset
|
|
|
|
(define input-field-clear
|
|
(lambda (input-field)
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(x-pos (if prompt
|
|
(string-length prompt)
|
|
0)))
|
|
(set-input-field-x-offset! input-field 0)
|
|
(set-input-field-y-offset! input-field 0)
|
|
(set-input-field-x-pos! input-field x-pos)
|
|
(set-input-field-y-pos! input-field 0)
|
|
(set-input-field-x-edit-pos! input-field x-pos)
|
|
(set-input-field-y-edit-pos! input-field 0)
|
|
(set-input-field-edit-lines! input-field (if prompt
|
|
(list (string->list prompt))
|
|
'(()))))))
|
|
|
|
(define input-field-reset
|
|
(lambda (input-field)
|
|
(let ((x-pos (let ((prompt (input-field-prompt input-field)))
|
|
(if prompt
|
|
(string-length prompt)
|
|
0))))
|
|
(set-input-field-x-offset! input-field 0)
|
|
(set-input-field-y-offset! input-field 0)
|
|
(set-input-field-x-pos! input-field x-pos)
|
|
(set-input-field-y-pos! input-field 0)
|
|
(set-input-field-x-edit-pos! input-field x-pos)
|
|
(set-input-field-y-edit-pos! input-field 0)
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-init-text input-field))))))
|
|
|
|
;; "basics" - clear/reset END
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; "basics" END
|
|
;;===============================================================================
|
|
|
|
;;===============================================================================
|
|
;; draw/refresh functions
|
|
|
|
(define paint-black
|
|
(lambda (input-field)
|
|
(let ((blank-string (make-string (input-field-x-dim input-field)
|
|
#\space))
|
|
(y-dim (input-field-y-dim input-field))
|
|
(x-loc (input-field-x-loc input-field))
|
|
(y-loc (input-field-y-loc input-field))
|
|
(win (input-field-window input-field)))
|
|
(let loop ((dy 0))
|
|
(if (= dy y-dim)
|
|
#t
|
|
(begin
|
|
(mvwaddstr win
|
|
(+ y-loc dy) x-loc
|
|
blank-string)
|
|
(loop (+ dy 1))))))))
|
|
|
|
|
|
(define refresh-position
|
|
(lambda (input-field)
|
|
(wmove (input-field-window input-field)
|
|
(+ (input-field-y-loc input-field)
|
|
(input-field-y-pos input-field))
|
|
(+ (input-field-x-loc input-field)
|
|
(input-field-x-pos input-field)))))
|
|
|
|
|
|
(define input-field-window-lines
|
|
(lambda (input-field)
|
|
(let ((x-loc (input-field-x-loc input-field))
|
|
(y-loc (input-field-y-loc input-field))
|
|
(x-dim (input-field-x-dim input-field))
|
|
(y-dim (input-field-y-dim input-field))
|
|
(x-offset (input-field-x-offset input-field))
|
|
(y-offset (input-field-y-offset input-field))
|
|
(win (input-field-window input-field)))
|
|
(let* ((input-field-lines (map (lambda (input-field-line)
|
|
(util-filter (lambda (char)
|
|
(not (char=? char #\newline)))
|
|
input-field-line))
|
|
(cat (map (lambda (edit-line)
|
|
(edit-line->input-field-lines input-field
|
|
edit-line))
|
|
(input-field-edit-lines input-field)))))
|
|
(input-field-lines-cut (take (drop (map (lambda (input-field-line)
|
|
(take (drop input-field-line
|
|
x-offset)
|
|
x-dim))
|
|
input-field-lines)
|
|
y-offset)
|
|
y-dim)))
|
|
input-field-lines-cut))))
|
|
|
|
(define refresh-all
|
|
(lambda (input-field)
|
|
(let ((x-loc (input-field-x-loc input-field))
|
|
(y-loc (input-field-y-loc input-field))
|
|
(x-dim (input-field-x-dim input-field))
|
|
(y-dim (input-field-y-dim input-field))
|
|
(x-offset (input-field-x-offset input-field))
|
|
(y-offset (input-field-y-offset input-field))
|
|
(win (input-field-window input-field)))
|
|
(let* ((input-field-lines-filled (map (lambda (input-field-line)
|
|
(fill-up input-field-line
|
|
x-dim
|
|
#\space))
|
|
(fill-up (map (lambda (input-field-line)
|
|
(fill-up input-field-line
|
|
x-dim
|
|
#\space))
|
|
(input-field-window-lines input-field))
|
|
; (edit-lines->input-field-lines input-field
|
|
; (input-field-edit-lines input-field)))
|
|
y-dim
|
|
'()))))
|
|
(let loop ((lines input-field-lines-filled)
|
|
(y-ofst 0))
|
|
(if (null? lines)
|
|
(refresh-position input-field)
|
|
(begin
|
|
(mvwaddstr win
|
|
(+ y-loc y-ofst)
|
|
x-loc
|
|
(list->string (car lines)))
|
|
(loop (cdr lines)
|
|
(+ y-ofst 1)))))))))
|
|
|
|
;; draw/refresh functions END
|
|
;;===============================================================================
|
|
|
|
;;===============================================================================
|
|
;; send-input-field
|
|
|
|
|
|
;; (values <known> <act>)....
|
|
;; <known> == #f wird direkt
|
|
;; von send-input-field abgefangen.
|
|
(define care-for-return
|
|
(lambda (input-field msg)
|
|
(case msg
|
|
((buffer-full)
|
|
(values 'buffer-full 'buffer-full)) ;; das ist böse²! sollte eigentlich über signals gemacht werden -- die konnte ich aber nicht catchen :'(
|
|
((just-position)
|
|
(refresh-position input-field)
|
|
(values #t #t))
|
|
((side-effect)
|
|
(values #t #f))
|
|
((#f) ;; konnte nichts machen
|
|
(values #t #f))
|
|
((#t) ;; etwas zugefügt oder entfernt
|
|
(refresh-all input-field)
|
|
(values #t #t))
|
|
(else
|
|
(values #t #f)))))
|
|
|
|
(define send-input-field
|
|
(lambda (input-field msg . args)
|
|
(if (integer? msg)
|
|
(cond ((get-behavior input-field msg) =>
|
|
(lambda (method)
|
|
(apply really-send-input-field input-field method args)))
|
|
(else (apply really-send-input-field input-field msg args)))
|
|
(values #f #f))))
|
|
|
|
(define really-send-input-field
|
|
(lambda (input-field msg . args)
|
|
(cond ((and (number? msg)
|
|
(or (and (> msg 31)
|
|
(< msg 127))
|
|
(= msg 10)
|
|
(= msg 13)))
|
|
(care-for-return input-field
|
|
(insert-char input-field
|
|
(if (= msg 13)
|
|
#\newline
|
|
(ascii->char msg)))))
|
|
((eq? msg 'move-prev-line)
|
|
(care-for-return input-field
|
|
(move-prev-line input-field)))
|
|
((eq? msg 'move-next-line)
|
|
(care-for-return input-field
|
|
(move-next-line input-field)))
|
|
((eq? msg 'move-left)
|
|
(care-for-return input-field
|
|
(move-left input-field)))
|
|
((eq? msg 'move-right)
|
|
(care-for-return input-field
|
|
(move-right input-field)))
|
|
((eq? msg 'delete-right)
|
|
(care-for-return input-field
|
|
(delete-right input-field)))
|
|
((eq? msg 'move-forward)
|
|
(care-for-return input-field
|
|
(move-forward input-field)))
|
|
((eq? msg 'move-backward)
|
|
(care-for-return input-field
|
|
(move-backward input-field)))
|
|
((eq? msg 'delete-left)
|
|
(care-for-return input-field
|
|
(delete-left input-field)))
|
|
((eq? msg 'delete-all-right)
|
|
(care-for-return input-field
|
|
(delete-all-right input-field)))
|
|
((eq? msg 'delete-all-left)
|
|
(care-for-return input-field
|
|
(delete-all-left input-field)))
|
|
((eq? msg 'delete-line)
|
|
(care-for-return input-field
|
|
(delete-line input-field)))
|
|
((eq? msg 'goto-begin-of-line)
|
|
(care-for-return input-field
|
|
(goto-begin-of-line input-field)))
|
|
((eq? msg 'goto-end-of-line)
|
|
(care-for-return input-field
|
|
(goto-end-of-line input-field)))
|
|
((eq? msg 'goto-begin-of-first-line)
|
|
(care-for-return input-field
|
|
(goto-begin-of-first-line input-field)))
|
|
((eq? msg 'goto-begin-of-last-line)
|
|
(care-for-return input-field
|
|
(goto-begin-of-last-line input-field)))
|
|
((eq? msg 'goto-begin-of-word-forward)
|
|
(care-for-return input-field
|
|
(goto-begin-of-word-forward input-field)))
|
|
((eq? msg 'goto-begin-of-word-backward)
|
|
(care-for-return input-field
|
|
(goto-begin-of-word-backward input-field)))
|
|
((eq? msg 'goto-end-of-word-forward)
|
|
(care-for-return input-field
|
|
(goto-begin-of-word-forward input-field)))
|
|
((eq? msg 'goto-end-of-word-backward)
|
|
(care-for-return input-field
|
|
(goto-begin-of-word-backward input-field)))
|
|
; ((eq? msg 'input-field-move-up)
|
|
; (care-for-return input-field
|
|
; (input-field-move-up input-field)))
|
|
; ((eq? msg 'input-field-move-down)
|
|
; (care-for-return input-field
|
|
; (input-field-move-down input-field)))
|
|
; ((eq? msg 'input-field-move-left)
|
|
; (care-for-return input-field
|
|
; (input-field-move-left input-field)))
|
|
; ((eq? msg 'input-field-move-right)
|
|
; (care-for-return input-field
|
|
; (input-field-move-right input-field)))
|
|
((eq? msg 'toggle-insert)
|
|
(care-for-return input-field
|
|
(toggle-insert input-field)))
|
|
((eq? msg 'restore)
|
|
(care-for-return input-field
|
|
(restore-input-field input-field)))
|
|
((eq? msg 'refresh-all)
|
|
(refresh-all input-field)
|
|
(values #t #t))
|
|
((list? msg)
|
|
(for-each (lambda (msg-single)
|
|
(send-input-field input-field
|
|
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 (input-field msg)
|
|
(let loop ((behavior (input-field-behavior input-field)))
|
|
(if (null? behavior)
|
|
#f
|
|
(if (eq? msg (caar behavior))
|
|
(cdar behavior)
|
|
(loop (cdr behavior)))))))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; move
|
|
|
|
(define move-prev-line
|
|
(lambda (input-field)
|
|
(if (first-line? input-field)
|
|
#f
|
|
(begin
|
|
(set-input-field-y-edit-pos! input-field
|
|
(- (input-field-y-edit-pos input-field)
|
|
1))
|
|
(prompt-pos-check input-field)
|
|
(sync-input-field-edit-pos input-field)))))
|
|
|
|
(define move-next-line
|
|
(lambda (input-field)
|
|
(if (last-line? input-field)
|
|
#f
|
|
(begin
|
|
(set-input-field-y-edit-pos! input-field
|
|
(+ (input-field-y-edit-pos input-field)
|
|
1))
|
|
(sync-input-field-edit-pos input-field)))))
|
|
|
|
(define move-left
|
|
(lambda (input-field)
|
|
(if (begin-of-line? input-field)
|
|
#f
|
|
(begin
|
|
(set-input-field-x-edit-pos! input-field
|
|
(- (input-field-x-edit-pos input-field)
|
|
1))
|
|
(prompt-pos-check input-field)
|
|
(sync-input-field-edit-pos input-field)))))
|
|
|
|
(define move-right
|
|
(lambda (input-field)
|
|
(if (or (end-of-line? input-field)
|
|
(and (right-border? input-field)
|
|
(lower-border? input-field)
|
|
(not (input-field-y-scroll input-field))
|
|
(not (input-field-x-scroll input-field))))
|
|
#f
|
|
(begin
|
|
(set-input-field-x-edit-pos! input-field
|
|
(+ (input-field-x-edit-pos input-field)
|
|
1))
|
|
(sync-input-field-edit-pos input-field)))))
|
|
|
|
(define move-forward
|
|
(lambda (input-field)
|
|
(cond ((move-right input-field) =>
|
|
id)
|
|
((move-next-line input-field)
|
|
(goto-begin-of-line input-field)
|
|
#t) ;;vorsichsthalber -- worst case -- vielleicht gescrollt
|
|
(else #f))))
|
|
|
|
(define move-backward
|
|
(lambda (input-field)
|
|
(cond ((move-left input-field) =>
|
|
id)
|
|
((move-prev-line input-field)
|
|
(goto-end-of-line input-field)
|
|
#t) ;;worst case
|
|
(else #f))))
|
|
|
|
(define sync-input-field-edit-pos
|
|
(lambda (input-field)
|
|
(call-with-values
|
|
(lambda ()
|
|
(edit-pos->input-field-pos input-field
|
|
(input-field-x-edit-pos input-field)
|
|
(input-field-y-edit-pos input-field)))
|
|
(lambda (x-pos y-pos)
|
|
(set-input-field-x-pos! input-field
|
|
(- x-pos (input-field-x-offset input-field)))
|
|
(set-input-field-y-pos! input-field
|
|
(- y-pos (input-field-y-offset input-field)))))
|
|
(legalize-position input-field)
|
|
(if (not (legal-offsets? input-field))
|
|
(legalize-offsets input-field))))
|
|
|
|
;; move END
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; scroll
|
|
|
|
(define scroll-up
|
|
(lambda (input-field)
|
|
(set-input-field-y-offset! input-field
|
|
(- (input-field-y-offset input-field)
|
|
1))
|
|
#t))
|
|
|
|
(define scroll-down
|
|
(lambda (input-field)
|
|
(set-input-field-y-offset! input-field
|
|
(+ (input-field-y-offset input-field)
|
|
1))
|
|
#t))
|
|
|
|
(define scroll-left
|
|
(lambda (input-field)
|
|
(set-input-field-x-offset! input-field
|
|
(- (input-field-x-offset input-field)
|
|
1))
|
|
#t))
|
|
|
|
(define scroll-right
|
|
(lambda (input-field)
|
|
(set-input-field-x-offset! input-field
|
|
(+ (input-field-x-offset input-field)
|
|
1))
|
|
#t))
|
|
;; scroll END
|
|
;; ----------------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------------
|
|
;; insert
|
|
|
|
(define insert-char
|
|
(lambda (input-field char)
|
|
(if (and (cursor-at-edit-end-position? input-field)
|
|
(space-left? input-field)
|
|
(not (char=? char #\newline)))
|
|
(begin
|
|
(set-input-field-edit-lines! input-field
|
|
(let ((rev-edit-lines
|
|
(reverse (input-field-edit-lines input-field))))
|
|
(reverse (cons (append (car rev-edit-lines)
|
|
(list char))
|
|
(cdr rev-edit-lines)))))
|
|
(move-right input-field))
|
|
(insert-char-complex input-field char))))
|
|
|
|
(define insert-char-complex
|
|
(lambda (input-field char)
|
|
(let* ((y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-lines (input-field-edit-lines input-field))
|
|
(current-line (list-ref edit-lines
|
|
y-edit-pos))
|
|
(new-lines-tmp (string->edit-lines
|
|
(list->string
|
|
((if (or (char=? char #\newline)
|
|
(input-field-insert-active input-field))
|
|
insert
|
|
replace)
|
|
current-line
|
|
(input-field-x-edit-pos input-field)
|
|
char))))
|
|
(new-lines (if (and (= (+ y-edit-pos 1)
|
|
(length edit-lines))
|
|
(end-of-line? input-field)
|
|
(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 (input-field-y-scroll input-field)
|
|
(= (length (edit-lines->input-field-lines input-field new-lines))
|
|
(length (edit-line->input-field-lines input-field current-line)))
|
|
(<= (length (edit-lines->input-field-lines input-field new-edit-lines))
|
|
(input-field-y-dim input-field)))
|
|
(begin (set-input-field-edit-lines! input-field new-edit-lines)
|
|
(if (char=? char #\newline)
|
|
(begin (set-input-field-x-edit-pos! input-field 0)
|
|
(set-input-field-y-edit-pos!
|
|
input-field
|
|
(+ (input-field-y-edit-pos input-field)
|
|
1))
|
|
(sync-input-field-edit-pos input-field))
|
|
(move-right input-field))
|
|
#t)
|
|
'buffer-full))))
|
|
; (signal 'buffer-full
|
|
; (input-field-x-edit-pos input-field)
|
|
; (input-field-y-edit-pos input-field))))))
|
|
|
|
;; insert END
|
|
;; ----------------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------------
|
|
;; delete
|
|
|
|
(define delete-right
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-lines (input-field-edit-lines input-field))
|
|
(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-input-field-edit-lines! input-field
|
|
(replace edit-lines
|
|
y-edit-pos
|
|
new-line))
|
|
#t)
|
|
#f))))
|
|
|
|
(define delete-left
|
|
(lambda (input-field)
|
|
(if (move-left input-field)
|
|
(delete-right input-field)
|
|
#f)))
|
|
|
|
(define delete-all-left
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-lines (input-field-edit-lines input-field))
|
|
(current-line (list-ref edit-lines
|
|
y-edit-pos)))
|
|
(if (not (zero? x-edit-pos))
|
|
(begin
|
|
(set-input-field-edit-lines! input-field
|
|
(replace edit-lines
|
|
y-edit-pos
|
|
(drop current-line
|
|
x-edit-pos)))
|
|
(set-input-field-x-edit-pos! input-field 0)
|
|
(sync-input-field-edit-pos input-field)
|
|
#t)
|
|
#f))))
|
|
|
|
(define delete-all-right
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-lines (input-field-edit-lines input-field))
|
|
(current-line (list-ref edit-lines
|
|
y-edit-pos)))
|
|
(if (and (end-of-line? input-field)
|
|
(not (last-line? input-field)))
|
|
(begin
|
|
(set-input-field-edit-lines! input-field
|
|
(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-input-field-edit-lines! input-field
|
|
(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 (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-lines (input-field-edit-lines input-field))
|
|
(edit-lines-len (length edit-lines))
|
|
(current-line (list-ref edit-lines
|
|
y-edit-pos)))
|
|
(if (= edit-lines-len 1)
|
|
(begin
|
|
(set-input-field-edit-lines! input-field
|
|
'(()))
|
|
(set-input-field-x-edit-pos! input-field
|
|
0)
|
|
(sync-input-field-edit-pos input-field))
|
|
(begin
|
|
(set-input-field-edit-lines! input-field
|
|
(remove edit-lines
|
|
y-edit-pos))
|
|
(set-input-field-x-edit-pos! input-field
|
|
0)
|
|
(set-input-field-y-edit-pos! input-field
|
|
(min y-edit-pos
|
|
(- edit-lines-len 2)))
|
|
(sync-input-field-edit-pos input-field))))))
|
|
|
|
;; delete END
|
|
;; ----------------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------------
|
|
;; goto
|
|
|
|
;; TODOO - fertig machen... (siehe #f)
|
|
|
|
(define goto-begin-of-word-forward
|
|
(lambda (input-field)
|
|
(goto-next-forward input-field #\space #\newline)
|
|
(goto-next-not-forward input-field #\space #\newline)
|
|
#t))
|
|
|
|
|
|
(define goto-end-of-word-forward
|
|
(lambda (input-field)
|
|
#f))
|
|
|
|
|
|
(define goto-begin-of-word-backward
|
|
(lambda (input-field)
|
|
(if (and (goto-next-not-backward input-field #\space #\newline)
|
|
(goto-next-backward input-field #\space #\newline))
|
|
(move-forward input-field))
|
|
#t))
|
|
|
|
(define goto-end-of-word-backward
|
|
(lambda (input-field)
|
|
#f))
|
|
|
|
(define goto-begin-of-line
|
|
(lambda (input-field)
|
|
(set-input-field-x-edit-pos! input-field 0)
|
|
(prompt-pos-check input-field)
|
|
(sync-input-field-edit-pos input-field)))
|
|
|
|
(define goto-end-of-line
|
|
(lambda (input-field)
|
|
(let ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(let* ((current-line (list-ref (input-field-edit-lines input-field)
|
|
y-edit-pos)))
|
|
(if (null? current-line)
|
|
(set-input-field-x-edit-pos! input-field 0)
|
|
(let ((len (length current-line))
|
|
(end-char (last current-line)))
|
|
(set-input-field-x-edit-pos! input-field
|
|
(if (char=? end-char
|
|
#\newline)
|
|
(- len 1)
|
|
len))))
|
|
(edit-pos->input-field-pos input-field
|
|
(input-field-x-edit-pos input-field)
|
|
y-edit-pos)))
|
|
(lambda (x-pos y-pos)
|
|
(set-input-field-x-pos! input-field
|
|
(- x-pos
|
|
(input-field-x-offset input-field)))
|
|
(set-input-field-y-pos! input-field
|
|
(- y-pos
|
|
(input-field-y-offset input-field)))
|
|
(sync-input-field-edit-pos input-field))))))
|
|
|
|
(define goto-begin-of-first-line
|
|
(lambda (input-field)
|
|
(set-input-field-x-edit-pos! input-field 0)
|
|
(set-input-field-y-edit-pos! input-field 0)
|
|
(prompt-pos-check input-field)
|
|
(sync-input-field-edit-pos input-field)))
|
|
|
|
(define goto-end-of-first-line
|
|
(lambda (input-field)
|
|
#f))
|
|
|
|
(define goto-begin-of-last-line
|
|
(lambda (input-field)
|
|
(set-input-field-x-edit-pos! input-field 0)
|
|
(set-input-field-y-edit-pos! input-field
|
|
(- (length (input-field-edit-lines input-field))
|
|
1))
|
|
(prompt-pos-check input-field)
|
|
(sync-input-field-edit-pos input-field)))
|
|
|
|
(define goto-end-of-last-line
|
|
(lambda (input-field)
|
|
(goto-begin-of-last-line input-field)
|
|
(goto-end-of-line input-field)))
|
|
|
|
(define goto-next-forward
|
|
(lambda (input-field . chars)
|
|
(if (move-forward input-field)
|
|
(let loop ()
|
|
(let ((sign (sign-under-cursor input-field)))
|
|
(if (and sign
|
|
(memq sign chars))
|
|
#t
|
|
(if (move-forward input-field)
|
|
(loop)
|
|
#f))))
|
|
#f)))
|
|
|
|
(define goto-next-not-forward
|
|
(lambda (input-field . chars)
|
|
(if (move-forward input-field)
|
|
(let loop ()
|
|
(let ((sign (sign-under-cursor input-field)))
|
|
(if (and sign
|
|
(not (memq sign chars)))
|
|
#t
|
|
(if (move-forward input-field)
|
|
(loop)
|
|
#f))))
|
|
#f)))
|
|
|
|
(define goto-next-backward
|
|
(lambda (input-field . chars)
|
|
(if (move-backward input-field)
|
|
(let loop ()
|
|
(let ((sign (sign-under-cursor input-field)))
|
|
(if (and sign
|
|
(memq sign chars))
|
|
(begin
|
|
(prompt-pos-check input-field)
|
|
#t)
|
|
(if (move-backward input-field)
|
|
(loop)
|
|
(begin
|
|
(prompt-pos-check input-field)
|
|
#f)))))
|
|
#f)))
|
|
|
|
(define goto-next-not-backward
|
|
(lambda (input-field . chars)
|
|
(if (move-backward input-field)
|
|
(let loop ()
|
|
(let ((sign (sign-under-cursor input-field)))
|
|
(if (and sign
|
|
(not (memq sign chars)))
|
|
(begin
|
|
(prompt-pos-check input-field)
|
|
#t)
|
|
(if (move-backward input-field)
|
|
(loop)
|
|
(begin
|
|
(prompt-pos-check input-field)
|
|
#f)))))
|
|
#f)))
|
|
|
|
;; goto END
|
|
;; ----------------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------------
|
|
;; others
|
|
(define toggle-insert
|
|
(lambda (input-field)
|
|
(set-input-field-insert-active!
|
|
input-field
|
|
(not (input-field-insert-active input-field)))))
|
|
;; others END
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; behavior methods END
|
|
;;===============================================================================
|
|
|
|
;;===============================================================================
|
|
;; "mutate" functions and few others
|
|
|
|
(define restore-input-field
|
|
(lambda (input-field)
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-text-wp input-field)))
|
|
(sync-input-field-edit-pos input-field)
|
|
#t))
|
|
|
|
(define input-field-refresh
|
|
(lambda (input-field)
|
|
(really-send-input-field input-field 'refresh-all)))
|
|
|
|
;(define input-field-move-up
|
|
; (lambda (input-field)
|
|
; (let ((y-loc (input-field-y-loc input-field)))
|
|
; (if (> y-loc 1)
|
|
; (begin
|
|
; (paint-black input-field)
|
|
; (set-input-field-y-loc! input-field (- y-loc
|
|
; 1))
|
|
; #t)
|
|
; #f))))
|
|
|
|
;(define input-field-move-down
|
|
; (lambda (input-field)
|
|
; (let ((y-loc (input-field-y-loc input-field)))
|
|
; (if (< (+ y-loc (input-field-y-dim input-field))
|
|
; (- (getmaxy (input-field-window input-field))
|
|
; 1))
|
|
; (begin
|
|
; (paint-black input-field)
|
|
; (set-input-field-y-loc! input-field (+ y-loc
|
|
; 1))
|
|
; #t)
|
|
; #f))))
|
|
|
|
;(define input-field-move-left
|
|
; (lambda (input-field)
|
|
; (let ((x-loc (input-field-x-loc input-field)))
|
|
; (if (> x-loc 1)
|
|
; (begin
|
|
; (paint-black input-field)
|
|
; (set-input-field-x-loc! input-field (- x-loc
|
|
; 1))
|
|
; #t)
|
|
; #f))))
|
|
|
|
;(define input-field-move-right
|
|
; (lambda (input-field)
|
|
; (let ((x-loc (input-field-x-loc input-field)))
|
|
; (if (< (+ x-loc (input-field-x-dim input-field))
|
|
; (- (getmaxx (input-field-window input-field))
|
|
; 1))
|
|
; (begin
|
|
; (paint-black input-field)
|
|
; (set-input-field-x-loc! input-field (+ x-loc
|
|
; 1))
|
|
; #t)
|
|
; #f))))
|
|
|
|
(define input-field-move
|
|
(lambda (input-field x y)
|
|
(let ((win (input-field-window input-field)))
|
|
(if (and (>= x 0)
|
|
(>= y 0)
|
|
(<= (+ x (input-field-x-dim input-field)) ; (input-field-x-loc input-field)) ;; + x-loc
|
|
(getmaxx win))
|
|
(<= (+ y (input-field-y-dim input-field)) ; (input-field-y-loc input-field)) ;; + y-loc
|
|
(getmaxy win)))
|
|
(begin
|
|
(paint-black input-field)
|
|
(set-input-field-x-loc! input-field x)
|
|
(set-input-field-y-loc! input-field y)
|
|
#t)
|
|
#f))))
|
|
|
|
(define input-field-resize
|
|
(lambda (input-field x y)
|
|
(let ((win (input-field-window input-field)))
|
|
(if (and (>= x 0)
|
|
(>= y 0)
|
|
(<= (+ x (input-field-x-loc input-field)) ; (input-field-x-dim input-field)) ;; + x-dim
|
|
(getmaxx win))
|
|
(<= (+ y (input-field-y-loc input-field)) ; (input-field-y-dim input-field)) ;; + y-dim
|
|
(getmaxy win)))
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(x-pos (if prompt
|
|
(string-length prompt)
|
|
0)))
|
|
(paint-black input-field)
|
|
(set-input-field-x-dim! input-field x)
|
|
(set-input-field-y-dim! input-field y)
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-text-wp input-field)))
|
|
(sync-input-field-edit-pos input-field)
|
|
(legalize-position input-field)
|
|
(if (not (legal-offsets? input-field))
|
|
(legalize-offsets input-field))
|
|
#t)
|
|
#f))))
|
|
|
|
(define input-field-toggle-x-scroll
|
|
(lambda (input-field)
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(x-pos (if prompt
|
|
(string-length prompt)
|
|
0)))
|
|
(paint-black input-field)
|
|
(set-input-field-x-scroll! input-field
|
|
(not (input-field-x-scroll input-field)))
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-text-wp input-field)))
|
|
(sync-input-field-edit-pos input-field)
|
|
(legalize-position input-field)
|
|
(if (not (legal-offsets? input-field))
|
|
(legalize-offsets input-field))
|
|
#t)))
|
|
|
|
(define input-field-toggle-y-scroll
|
|
(lambda (input-field)
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(x-pos (if prompt
|
|
(string-length prompt)
|
|
0)))
|
|
(paint-black input-field)
|
|
(set-input-field-y-scroll! input-field
|
|
(not (input-field-y-scroll input-field)))
|
|
(set-input-field-edit-lines!
|
|
input-field
|
|
(string->input-field-edit-lines input-field
|
|
(input-field-text-wp input-field)))
|
|
(sync-input-field-edit-pos input-field)
|
|
(legalize-position input-field)
|
|
(if (not (legal-offsets? input-field))
|
|
(legalize-offsets input-field))
|
|
#t)))
|
|
|
|
;; 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->input-field-lines
|
|
(lambda (input-field edit-line)
|
|
(let ((x-dim (input-field-x-dim input-field))
|
|
(x-scroll (input-field-x-scroll input-field)))
|
|
(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-input-field-line-from-edit-line x-dim edit-line))
|
|
(lambda (input-field-line edit-line)
|
|
(cons input-field-line
|
|
(loop edit-line))))))))))
|
|
|
|
(define edit-lines->input-field-lines
|
|
(lambda (input-field edit-lines)
|
|
(cat (map (lambda (edit-line)
|
|
(edit-line->input-field-lines input-field edit-line))
|
|
edit-lines))))
|
|
|
|
(define split-input-field-line-from-edit-line
|
|
(lambda (x-dim edit-line)
|
|
(let loop ((input-field-line '())
|
|
(rest edit-line)
|
|
(space-left x-dim))
|
|
(if (null? rest)
|
|
(values (reverse input-field-line)
|
|
rest)
|
|
(let ((char (car rest)))
|
|
(cond ((char=? char #\newline)
|
|
(values (reverse (cons char
|
|
input-field-line))
|
|
(cdr rest)))
|
|
((zero? space-left)
|
|
(values (reverse input-field-line)
|
|
rest))
|
|
(else
|
|
(loop (cons char input-field-line)
|
|
(cdr rest)
|
|
(- space-left 1)))))))))
|
|
|
|
(define input-field-lines->edit-lines
|
|
(lambda (input-field-lines)
|
|
(let loop ((rest input-field-lines))
|
|
(if (null? rest)
|
|
'()
|
|
(call-with-values
|
|
(lambda ()
|
|
(split-edit-line-from-input-field-lines rest))
|
|
(lambda (edit-line rest)
|
|
(cons edit-line
|
|
(loop rest))))))))
|
|
|
|
(define split-edit-line-from-input-field-lines
|
|
(lambda (input-field-lines)
|
|
(let loop ((edit-line '())
|
|
(rest input-field-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->input-field-edit-lines
|
|
(lambda (input-field string)
|
|
(let* ((edit-lines (string->edit-lines-with-null string))
|
|
(input-field-lines (edit-lines->input-field-lines input-field edit-lines))
|
|
(input-field-lines-cut (if (input-field-y-scroll input-field)
|
|
input-field-lines
|
|
(take input-field-lines
|
|
(input-field-y-dim input-field)))))
|
|
(input-field-lines->edit-lines input-field-lines-cut))))
|
|
|
|
(define input-field->edit-pos
|
|
(lambda (input-field)
|
|
(let ((x-pos (+ (input-field-x-offset input-field)
|
|
(input-field-x-pos input-field)))
|
|
(y-pos (+ (input-field-y-offset input-field)
|
|
(input-field-y-pos input-field)))
|
|
(x-scroll (input-field-x-scroll input-field)))
|
|
(if x-scroll
|
|
(values x-pos y-pos)
|
|
(let loop ((edit-lines (input-field-edit-lines input-field))
|
|
(y-edit-pos 0)
|
|
(y-pos y-pos))
|
|
(if (null? edit-lines)
|
|
(let ((y-edit-pos (- y-edit-pos 1)))
|
|
(values (length (list-ref (input-field-edit-lines input-field)
|
|
y-edit-pos))
|
|
y-edit-pos))
|
|
(let* ((edit-line (car edit-lines))
|
|
(num-input-field-lines
|
|
(length
|
|
(edit-line->input-field-lines input-field edit-line))))
|
|
(if (< y-pos num-input-field-lines)
|
|
(values (+ (* y-pos
|
|
(input-field-x-dim input-field))
|
|
x-pos)
|
|
y-edit-pos)
|
|
(loop (cdr edit-lines)
|
|
(+ y-edit-pos 1)
|
|
(- y-pos num-input-field-lines))))))))))
|
|
|
|
(define edit-pos->input-field-pos
|
|
(lambda (input-field x-edit-pos y-edit-pos)
|
|
(if (input-field-x-scroll input-field)
|
|
(values x-edit-pos y-edit-pos)
|
|
(let loop ((edit-lines (input-field-edit-lines input-field))
|
|
(y-edit-pos y-edit-pos)
|
|
(y-pos 0))
|
|
(if (null? edit-lines)
|
|
'error--edit-pos->input-field-pos
|
|
(if (zero? y-edit-pos)
|
|
(let ((x-dim (input-field-x-dim input-field)))
|
|
(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->input-field-lines input-field
|
|
(car edit-lines)))))))))))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; legalize-position
|
|
(define legalize-position
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(current-line (list-ref (input-field-edit-lines input-field)
|
|
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 input-field)))
|
|
#t))
|
|
|
|
(define prompt-pos-check
|
|
(lambda (input-field)
|
|
(if (zero? (input-field-y-edit-pos input-field))
|
|
(let ((prompt (input-field-prompt input-field)))
|
|
(if prompt
|
|
(let ((prompt-length (string-length prompt)))
|
|
(if (< (input-field-x-edit-pos input-field)
|
|
prompt-length)
|
|
(set-input-field-x-edit-pos! input-field prompt-length))))))))
|
|
|
|
(define legal-offsets?
|
|
(lambda (input-field)
|
|
(let ((x (input-field-x-pos input-field))
|
|
(y (input-field-y-pos input-field)))
|
|
(and (>= x 0)
|
|
(< x (input-field-x-dim input-field))
|
|
(>= y 0)
|
|
(< y (input-field-y-dim input-field))))))
|
|
|
|
|
|
(define legalize-offsets
|
|
(lambda (input-field)
|
|
(let ((x-pos (input-field-x-pos input-field))
|
|
(x-offset (input-field-x-offset input-field))
|
|
(x-dim (input-field-x-dim input-field))
|
|
(y-pos (input-field-y-pos input-field))
|
|
(y-offset (input-field-y-offset input-field))
|
|
(y-dim (input-field-y-dim input-field)))
|
|
(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-input-field-x-pos! input-field x-pos)
|
|
(set-input-field-x-offset! input-field x-offset)
|
|
(set-input-field-y-pos! input-field y-pos)
|
|
(set-input-field-y-offset! input-field y-offset)
|
|
#t)))
|
|
;; legalize-position END
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; predicates
|
|
|
|
(define first-line?
|
|
(lambda (input-field)
|
|
(zero? (input-field-y-edit-pos input-field))))
|
|
|
|
(define last-line?
|
|
(lambda (input-field)
|
|
(= (+ (input-field-y-edit-pos input-field)
|
|
1)
|
|
(length (input-field-edit-lines input-field)))))
|
|
|
|
(define begin-of-line?
|
|
(lambda (input-field)
|
|
(zero? (input-field-x-edit-pos input-field))))
|
|
|
|
(define end-of-line?
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(edit-line (list-ref (input-field-edit-lines input-field)
|
|
y-edit-pos)))
|
|
(or (= x-edit-pos
|
|
(length edit-line))
|
|
(char=? (list-ref edit-line
|
|
x-edit-pos)
|
|
#\newline)))))
|
|
|
|
(define cursor-at-edit-end-position?
|
|
(lambda (input-field)
|
|
(and (end-of-line? input-field)
|
|
(last-line? input-field))))
|
|
|
|
(define left-border?
|
|
(lambda (input-field)
|
|
(= (input-field-x-pos input-field)
|
|
0)))
|
|
|
|
(define right-border?
|
|
(lambda (input-field)
|
|
(= (input-field-x-pos input-field)
|
|
(- (input-field-x-dim input-field) 1))))
|
|
|
|
(define lower-border?
|
|
(lambda (input-field)
|
|
(= (input-field-y-pos input-field)
|
|
(- (input-field-y-dim input-field) 1))))
|
|
|
|
(define upper-border?
|
|
(lambda (input-field)
|
|
(= (input-field-y-pos input-field)
|
|
0)))
|
|
|
|
(define space-left?
|
|
(lambda (input-field)
|
|
(not (and (lower-border? input-field)
|
|
(right-border? input-field)))))
|
|
|
|
;; predicates END
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; selectors
|
|
|
|
(define sign-under-cursor
|
|
(lambda (input-field)
|
|
(let* ((x-edit-pos (input-field-x-edit-pos input-field))
|
|
(y-edit-pos (input-field-y-edit-pos input-field))
|
|
(current-line (list-ref (input-field-edit-lines input-field)
|
|
y-edit-pos))
|
|
(current-line-len (length current-line)))
|
|
(if (< x-edit-pos current-line-len)
|
|
(list-ref current-line x-edit-pos)
|
|
#f))))
|
|
|
|
;; selectors END
|
|
;; ----------------------------------------------------------------------------
|
|
;; helpfunctions END
|
|
;;===============================================================================
|
|
|
|
|
|
;;===============================================================================
|
|
;; "primitives"
|
|
|
|
(define id
|
|
(lambda (x)
|
|
x))
|
|
|
|
(define caddddr
|
|
(lambda (x)
|
|
(car (cddddr x))))
|
|
|
|
(define cadddddr
|
|
(lambda (x)
|
|
(car (cdr (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)))))
|
|
|
|
;; "save" versions of take and drop
|
|
|
|
(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)))))
|
|
|