You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
194 lines
6.3 KiB
Scheme
194 lines
6.3 KiB
Scheme
; dyn-edit
|
|
;
|
|
; Defines spidey:dynamic+margin-edit%, a subclass of spidey:static-edit%
|
|
; with an insert-line method that also inserts a margin
|
|
; and it handles adding and deleting snips
|
|
; while still allowing static positions in the buffer
|
|
;
|
|
; ----------------------------------------------------------------------
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
|
;
|
|
; This program is free software; you can redistribute it and/or
|
|
; modify it under the terms of the GNU General Public License
|
|
; version 2 as published by the Free Software Foundation.
|
|
;
|
|
; This program is distributed in the hope that it will be useful,
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
; GNU General Public License for more details.
|
|
;
|
|
; You should have received a copy of the GNU General Public License
|
|
; along with this program; if not, write to the Free Software
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define spidey:dynamic+margin-edit%
|
|
(class spidey:static-edit% (arg-margin . init-args)
|
|
(inherit
|
|
set-auto-set-wrap
|
|
load-file last-position position-line
|
|
lock get-style-list
|
|
begin-edit-sequence end-edit-sequence edit-sequence
|
|
|
|
change-style
|
|
set-clickback
|
|
flash-on
|
|
set-position
|
|
scroll-to-position
|
|
get-text
|
|
insert
|
|
delete
|
|
set-tabs
|
|
)
|
|
|
|
(public
|
|
;; ----------
|
|
margin
|
|
margin-length
|
|
;[margin " "]
|
|
;[margin-length 2]
|
|
|
|
;; keeps a list of all the snips in their source-locations
|
|
[sniplist ()]
|
|
|
|
[insert-line
|
|
(lambda (s)
|
|
(insert margin)
|
|
(insert s)
|
|
(insert (string #\newline)))]
|
|
|
|
;; ----------
|
|
|
|
[account-for-margin
|
|
(lambda (pos)
|
|
(recur loop ([try pos])
|
|
;;(pretty-debug-gui `(accout-for-margin ,pos ,try))
|
|
(let ([better
|
|
(+ pos
|
|
(* margin-length (add1 (position-line (+ try 0)))))])
|
|
(if (= better try)
|
|
try
|
|
(loop better)))))]
|
|
[real-start-position
|
|
(lambda (pos)
|
|
(account-for-margin
|
|
(let loop ([l sniplist])
|
|
(cond
|
|
[(null? l) pos]
|
|
[(> pos (car l)) (add1 (loop (cdr l)))]
|
|
[else (loop (cdr l))]))))]
|
|
[real-end-position
|
|
(lambda (pos)
|
|
(account-for-margin
|
|
(let loop ([l sniplist])
|
|
(cond
|
|
[(null? l) pos]
|
|
[(>= pos (car l)) (add1 (loop (cdr l)))]
|
|
[else (loop (cdr l))]))))]
|
|
[old-real-end-position
|
|
(lambda (pos)
|
|
(let ([pos pos])
|
|
(let loop ([l sniplist][pos pos])
|
|
(cond
|
|
[(null? l) (account-for-margin pos)]
|
|
[(>= pos (car l))
|
|
(loop (cdr l) (add1 pos))]
|
|
[else (loop (cdr l) pos)]))))]
|
|
[frame-pos->source-pos
|
|
(lambda (pos)
|
|
(assert (number? pos) 'frame-pos->source-pos)
|
|
(let ([pos (- pos (* margin-length (add1 (position-line pos))))])
|
|
(let loop ([l sniplist])
|
|
(cond
|
|
[(null? l) pos]
|
|
[(> pos (car l))
|
|
(sub1 (loop (cdr l)))]
|
|
[else (loop (cdr l))]))))]
|
|
|
|
;; ----------
|
|
|
|
[relocate-change-style
|
|
(lambda (delta src-start src-end)
|
|
(let ([s (real-start-position src-start)]
|
|
[e (real-end-position src-end)])
|
|
(pretty-debug-gui `(change-style ,src-start ,src-end ,s ,e))
|
|
(change-style delta s e)))]
|
|
|
|
[relocate-set-clickback
|
|
(lambda (src-start src-end . args)
|
|
(apply set-clickback
|
|
(real-start-position src-start)
|
|
(real-end-position src-end)
|
|
args))]
|
|
[relocate-flash-on
|
|
(lambda (src-start src-end a b c)
|
|
(flash-on (real-start-position src-start)
|
|
(real-end-position src-end) a b c))]
|
|
[relocate-scroll-to-position
|
|
(lambda (pos)
|
|
(let ([real-pos (real-start-position pos)])
|
|
'(pretty-print `(scroll-to-position ,pos ,real-pos))
|
|
(set-position real-pos)
|
|
(scroll-to-position real-pos)))]
|
|
;;
|
|
;; watch this function......
|
|
[relocate-set-position
|
|
(opt-lambda
|
|
(pos [end -1][eol #f][scroll #t])
|
|
(let ([end (if (= end -1) -1 (real-end-position end))])
|
|
(set-position (real-start-position pos) end
|
|
eol scroll)))]
|
|
[match-paren-forward
|
|
(lambda (source-start)
|
|
(frame-pos->source-pos (mred:scheme-forward-match
|
|
this (real-start-position source-start)
|
|
(last-position))))]
|
|
|
|
[relocate-get-text
|
|
(opt-lambda ([start -1][end -1][flat #f])
|
|
(get-text (real-start-position start)
|
|
(real-end-position end) flat))]
|
|
[select-snip
|
|
(lambda (pos snip)
|
|
(edit-sequence
|
|
(lambda ()
|
|
(send (send snip get-this-media) own-caret #f)
|
|
(set-position
|
|
(real-end-position pos) (real-start-position pos)))))]
|
|
[relocate-insert-snip
|
|
(lambda (snip pos)
|
|
;;(lock #f)
|
|
(when (member pos sniplist)
|
|
(error "Cannot put two snips in the same position~n"))
|
|
(let ([real-pos (real-start-position pos)])
|
|
(set! sniplist (cons pos sniplist))
|
|
(insert snip real-pos))
|
|
;;(lock #t)
|
|
)]
|
|
[relocate-delete-snip
|
|
(lambda (pos)
|
|
(unless (member pos sniplist)
|
|
(error "Cannot remove snip from ~s" pos))
|
|
(set! sniplist (remv pos sniplist))
|
|
(let ([pos (real-start-position pos)])
|
|
(delete pos (add1 pos))))]
|
|
)
|
|
|
|
(sequence
|
|
(apply super-init init-args)
|
|
(set! margin arg-margin)
|
|
(set! margin-length (string-length margin))
|
|
|
|
(set-auto-set-wrap #f)
|
|
;; set-tabs doesn't work right past list of specified tabs
|
|
;; so specify all tabs to column 200
|
|
(set-tabs
|
|
(recur loop ([p margin-length])
|
|
(if (< p 200)
|
|
(cons p (loop (+ p 8)))
|
|
'()))
|
|
8
|
|
#f)
|
|
)))
|
|
|