280 lines
9.1 KiB
Plaintext
280 lines
9.1 KiB
Plaintext
;;;;
|
|
;;;; e d i t o r . s t k -- A small editor to create enhanced
|
|
;;;; text (used for Help page construction)
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; This software is a derivative work of other copyrighted softwares; the
|
|
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
;;;; Creation date: 6-Dec-1993 17:25
|
|
;;;; Last file update: 3-Sep-1999 19:50 (eg)
|
|
|
|
(select-module Tk)
|
|
(provide "editor")
|
|
|
|
;;;;
|
|
;;;; Font definition
|
|
;;;;
|
|
|
|
(define stk:STF-signature "STF-0.1")
|
|
|
|
(define stk:normal-font "*-Courier-Medium-R-Normal-*-120-*")
|
|
|
|
(define stk:all-fonts `(
|
|
(normal ,stk:normal-font)
|
|
(fixed "fixed")
|
|
(big "-*-times-*-r-*-*-*-240-*-*-*-*-*-*")
|
|
(roman-12 "-*-times-*-r-*-*-*-120-*-*-*-*-*-*")
|
|
(roman-14 "-*-times-*-r-*-*-*-140-*-*-*-*-*-*")
|
|
(roman-16 "-*-times-*-r-*-*-*-160-*-*-*-*-*-*")
|
|
(roman-18 "-*-times-*-r-*-*-*-180-*-*-*-*-*-*")
|
|
(italic-12 "-*-times-*-i-*-*-*-120-*-*-*-*-*-*")
|
|
(italic-14 "-*-times-*-i-*-*-*-140-*-*-*-*-*-*")
|
|
(italic-16 "-*-times-*-i-*-*-*-160-*-*-*-*-*-*")
|
|
(italic-18 "-*-times-*-i-*-*-*-180-*-*-*-*-*-*")
|
|
(bold-12 "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
|
|
(bold-14 "-*-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*")
|
|
(bold-16 "-*-helvetica-bold-r-*-*-*-160-*-*-*-*-*-*")
|
|
(bold-18 "-*-helvetica-bold-r-*-*-*-180-*-*-*-*-*-*")
|
|
(bold-italic-12 "-*-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
|
|
(bold-italic-14 "-*-helvetica-bold-o-*-*-*-140-*-*-*-*-*-*")
|
|
(bold-italic-16 "-*-helvetica-bold-o-*-*-*-160-*-*-*-*-*-*")
|
|
(bold-italic-18 "-*-helvetica-bold-o-*-*-*-180-*-*-*-*-*-*")
|
|
(tty-12 "-adobe-courier-medium-*-*-*-*-120-*-*-*-*-*-*")
|
|
(tty-14 "-adobe-courier-medium-*-*-*-*-140-*-*-*-*-*-*")
|
|
(tty-16 "-adobe-courier-medium-*-*-*-*-160-*-*-*-*-*-*")
|
|
(tty-18 "-adobe-courier-medium-*-*-*-*-180-*-*-*-*-*-*")))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Fonts utilities
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (stk:unset-tags editor-window start end)
|
|
(for-each (lambda (tag)
|
|
(editor-window 'tag 'remove (car tag) start end))
|
|
stk:all-fonts))
|
|
|
|
(define (stk:set-font editor-window font start end)
|
|
;; Be sure this tag exists
|
|
(editor-window 'tag 'conf font :font (cadr (assoc font stk:all-fonts)))
|
|
;; Delete all the tags associated to this range
|
|
(stk:unset-tags editor-window start end)
|
|
;; Set a new tag for this character range
|
|
(editor-window 'tag 'add font start end))
|
|
|
|
(define (stk:set-underline editor-window start end)
|
|
(editor-window 'tag 'conf 'underline :underline #t)
|
|
(editor-window 'tag 'add 'underline start end))
|
|
|
|
(define (stk:fontify-selection editor-window font)
|
|
(catch
|
|
(stk:set-font editor-window
|
|
font
|
|
(editor-window 'index 'sel.first)
|
|
(editor-window 'index 'sel.last))))
|
|
|
|
(define (stk:underline-selection editor-window value)
|
|
(catch
|
|
(let ((start (editor-window 'index 'sel.first))
|
|
(end (editor-window 'index 'sel.last)))
|
|
;; Remove all underlining information in this area
|
|
(editor-window 'tag 'remove 'underline start end)
|
|
;; Set underline if value is #t
|
|
(when value (stk:set-underline editor-window start end)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Scheme Text Format (STF) management
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (stk:get-STF editor-window)
|
|
(list stk:STF-signature
|
|
(editor-window 'get "1.0" 'end)
|
|
(let ((l '()))
|
|
(for-each (lambda (t)
|
|
(let ((tags (editor-window 'tag 'range (car t))))
|
|
(unless (null? tags)
|
|
(set! l (cons (list (car t) tags) l)))))
|
|
(cons `(underline #f) stk:all-fonts))
|
|
l)))
|
|
|
|
(define (stk:set-STF editor-window STF)
|
|
(let ((text (cadr STF)) (fmts (caddr STF)))
|
|
;; First insert new text
|
|
(editor-window 'delete "1.0" 'end)
|
|
(editor-window 'insert "1.0" text)
|
|
(editor-window 'mark 'set 'insert "1.0")
|
|
;; And now enhence it
|
|
(for-each (lambda (t)
|
|
(do ((l (cadr t) (cddr l)))
|
|
((null? l))
|
|
(if (eqv? (car t) 'underline)
|
|
(stk:set-underline editor-window (car l) (cadr l))
|
|
(stk:set-font editor-window (car t) (car l) (cadr l)))))
|
|
fmts))
|
|
(update))
|
|
|
|
(define (stk:write-file editor-window file)
|
|
(with-output-to-file file
|
|
(lambda ()
|
|
(format #t ";;;; ~S\n" stk:STF-signature)
|
|
(format #t "~S\n" (stk:get-STF editor-window)))))
|
|
|
|
|
|
(define (stk:write-file-ascii editor-window file)
|
|
(with-output-to-file file
|
|
(lambda ()
|
|
(format #t "~A" (editor-window 'get "1.0" 'end)))))
|
|
|
|
(define (stk:read-file editor-window file)
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(let ((first-line (read-line)))
|
|
(if (string=? first-line (format #f ";;;; ~S" stk:STF-signature))
|
|
;; File is a STF file
|
|
(stk:set-STF editor-window (read))
|
|
;; File must be read as a "normal" file
|
|
(begin
|
|
(editor-window 'delete "1.0" 'end)
|
|
(do ((l first-line (read-line)))
|
|
((eof-object? l))
|
|
(editor-window 'insert 'end l)
|
|
(editor-window 'insert 'end "\n"))
|
|
(editor-window 'mark 'set 'insert "1.0")))))))
|
|
|
|
(define (stk:get-filename toplevel) ; return the content of the file name entry
|
|
(let ((entry (string->widget (& toplevel ".bt.e"))))
|
|
(entry 'get)))
|
|
|
|
(define (stk:set-filename toplevel filename)
|
|
(let ((entry (string->widget (& toplevel ".bt.e"))))
|
|
(entry 'delete 0 'end)
|
|
(entry 'insert 0 filename)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Interface
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (stk:make-editor name . exit_code)
|
|
(let* ((top (toplevel name))
|
|
(menu-bar (frame (& name ".mb") :bd 2 :relief "groove"))
|
|
(bottom (frame (& name ".bt")))
|
|
(text-area (frame (& name ".ta")))
|
|
(exit_code (if (null? exit_code) `(destroy ,top) (car exit_code)))
|
|
(the-editor ()))
|
|
|
|
;;
|
|
;; Window manager management
|
|
;;
|
|
(wm 'maxsize name 1000 800)
|
|
(wm 'protocol name "WM_DELETE_WINDOW" exit_code)
|
|
|
|
;;
|
|
;; Text area frame
|
|
;;
|
|
(pack [scrollbar (& text-area ".sc") :orient "vert"
|
|
:bd 2
|
|
:relief "groove"
|
|
:command (format #f "~A 'yview"
|
|
(& text-area ".ed"))]
|
|
:side "left" :fill "y")
|
|
(pack [text (& text-area ".ed") :padx 4
|
|
:pady 4
|
|
:bd 2
|
|
:wrap "word"
|
|
:relief "groove"
|
|
:yscroll (format #f "~A 'set"
|
|
(& text-area ".sc"))]
|
|
:side "right" :expand #t :fill "both")
|
|
|
|
(set! the-editor (string->widget (& text-area ".ed")))
|
|
|
|
;;
|
|
;; Menu Creation
|
|
;;
|
|
|
|
(let* ((File (menubutton (& menu-bar ".file")
|
|
:text "File"
|
|
:padx 10
|
|
:menu (& menu-bar ".file.m")))
|
|
(m (eval (menu (& menu-bar ".file.m")))))
|
|
|
|
(m 'add 'command
|
|
:label " Read "
|
|
:command `(stk:read-file ,the-editor (stk:get-filename ,top)))
|
|
(m 'add 'command
|
|
:label " Save "
|
|
:command `(stk:write-file ,the-editor (stk:get-filename ,top)))
|
|
(m 'add 'command
|
|
:label " Save Ascii "
|
|
:command `(stk:write-file-ascii ,the-editor (stk:get-filename ,top)))
|
|
(m 'add 'separator)
|
|
(m 'add 'command :label " Quit " :command exit_code)
|
|
|
|
(pack File :side "left"))
|
|
|
|
(let* ((Font (menubutton (& menu-bar ".font")
|
|
:text "Font"
|
|
:padx 10
|
|
:menu (& menu-bar ".font.m")))
|
|
(m (eval (menu (& menu-bar ".font.m")))))
|
|
|
|
(for-each (lambda(font)
|
|
(m 'add 'command
|
|
:label (car font)
|
|
:font (cadr font)
|
|
:command `(stk:fontify-selection ,the-editor
|
|
',(car font))))
|
|
stk:all-fonts)
|
|
(m 'add 'separator)
|
|
(m 'add 'command
|
|
:label "Underline"
|
|
:command `(stk:underline-selection ,the-editor #t))
|
|
(m 'add 'command
|
|
:label "No underline"
|
|
:command `(stk:underline-selection ,the-editor #f))
|
|
|
|
(pack Font :side "left"))
|
|
|
|
;;
|
|
;; Bottom frame
|
|
;;
|
|
(pack [label (& bottom ".l") :text "File name" :padx 10] :side "left")
|
|
(pack [entry (& bottom ".e") :relief "ridge"] :side "left" :expand #t :fill "x")
|
|
|
|
;;
|
|
;; Pack everybody
|
|
;;
|
|
(pack menu-bar :fill "x")
|
|
(pack text-area :expand #t :fill "both")
|
|
(pack bottom :fill "x" :ipady 4 :ipadx 10)))
|
|
|
|
|
|
;; A simple editor accessible from prompt
|
|
(define (ed . file)
|
|
(require "editor")
|
|
(let ((editor-name (gensym ".editor")))
|
|
(stk:make-editor editor-name)
|
|
(unless (null? file)
|
|
(stk:read-file (string->widget (& editor-name ".ta.ed")) (car file))
|
|
(stk:set-filename editor-name (car file)))))
|
|
|