home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / editor.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  9.1 KB  |  277 lines
  1. ;;;; e d i t o r . s t k        -- A small editor to create enhanced
  2. ;;;;                       text (used for Help page construction)
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  18. ;;;;    Creation date:  6-Dec-1993 17:25
  19. ;;;; Last file update: 17-Oct-1994 18:41
  20.  
  21. (provide "editor")
  22.  
  23. ;;;;
  24. ;;;; Font definition
  25. ;;;;
  26.  
  27. (define stk:STF-signature "STF-0.1")
  28.  
  29. (define stk:normal-font "*-Courier-Medium-R-Normal-*-120-*")
  30.  
  31. (define stk:all-fonts `(
  32.    (normal        ,stk:normal-font)
  33.    (fixed        "fixed")
  34.    (big            "-*-times-*-r-*-*-*-240-*-*-*-*-*-*")
  35.    (roman-12        "-*-times-*-r-*-*-*-120-*-*-*-*-*-*")
  36.    (roman-14        "-*-times-*-r-*-*-*-140-*-*-*-*-*-*")
  37.    (roman-16        "-*-times-*-r-*-*-*-160-*-*-*-*-*-*")
  38.    (roman-18        "-*-times-*-r-*-*-*-180-*-*-*-*-*-*")
  39.    (italic-12        "-*-times-*-i-*-*-*-120-*-*-*-*-*-*")
  40.    (italic-14        "-*-times-*-i-*-*-*-140-*-*-*-*-*-*")
  41.    (italic-16        "-*-times-*-i-*-*-*-160-*-*-*-*-*-*")
  42.    (italic-18        "-*-times-*-i-*-*-*-180-*-*-*-*-*-*")
  43.    (bold-12        "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
  44.    (bold-14        "-*-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*")
  45.    (bold-16        "-*-helvetica-bold-r-*-*-*-160-*-*-*-*-*-*")
  46.    (bold-18        "-*-helvetica-bold-r-*-*-*-180-*-*-*-*-*-*")
  47.    (bold-italic-12    "-*-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
  48.    (bold-italic-14    "-*-helvetica-bold-o-*-*-*-140-*-*-*-*-*-*")
  49.    (bold-italic-16    "-*-helvetica-bold-o-*-*-*-160-*-*-*-*-*-*")
  50.    (bold-italic-18    "-*-helvetica-bold-o-*-*-*-180-*-*-*-*-*-*")
  51.    (tty-12        "-adobe-courier-medium-*-*-*-*-120-*-*-*-*-*-*")
  52.    (tty-14        "-adobe-courier-medium-*-*-*-*-140-*-*-*-*-*-*")
  53.    (tty-16        "-adobe-courier-medium-*-*-*-*-160-*-*-*-*-*-*")
  54.    (tty-18        "-adobe-courier-medium-*-*-*-*-180-*-*-*-*-*-*")))
  55.  
  56.  
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. ;;;;
  59. ;;;; Fonts utilities
  60. ;;;;
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62.  
  63. (define (stk:unset-tags editor-window start end)
  64.   (for-each (lambda (tag) 
  65.           (editor-window 'tag 'remove (car tag) start end))
  66.         stk:all-fonts))
  67.   
  68. (define (stk:set-font editor-window font start end)
  69.   ;; Be sure this tag exists
  70.   (editor-window 'tag 'conf font :font (cadr (assoc font stk:all-fonts)))
  71.   ;; Delete all the tags associated to this range
  72.   (stk:unset-tags editor-window start end)
  73.   ;; Set a new tag for this character range
  74.   (editor-window 'tag 'add font start end))
  75.  
  76. (define (stk:set-underline editor-window start end)
  77.   (editor-window 'tag 'conf 'underline :underline #t)
  78.   (editor-window 'tag 'add 'underline start end))
  79.  
  80. (define (stk:fontify-selection editor-window font)
  81.   (catch
  82.      (stk:set-font editor-window 
  83.            font 
  84.            (editor-window 'index 'sel.first)
  85.            (editor-window 'index 'sel.last))))
  86.  
  87. (define (stk:underline-selection editor-window value)
  88.   (catch
  89.      (let ((start (editor-window 'index 'sel.first))
  90.        (end   (editor-window 'index 'sel.last)))
  91.        ;; Remove all underlining information in this area
  92.        (editor-window 'tag 'remove 'underline start end)
  93.        ;; Set underline if value is #t
  94.        (when value (stk:set-underline editor-window start end)))))
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97. ;;;;
  98. ;;;; Scheme Text Format (STF) management
  99. ;;;;
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101.  
  102. (define (stk:get-STF editor-window)
  103.   (list stk:STF-signature
  104.     (editor-window 'get "1.0" 'end)
  105.     (let ((l '()))
  106.       (for-each (lambda (t)
  107.               (let ((tags (editor-window 'tag 'range (car t))))
  108.             (unless (null? tags)
  109.                (set! l (cons (list (car t) tags) l)))))
  110.             (cons `(underline #f) stk:all-fonts))
  111.       l)))
  112.  
  113. (define (stk:set-STF editor-window STF)
  114.   (let ((text (cadr STF)) (fmts (caddr STF)))
  115.     ;; First insert new text
  116.     (editor-window 'delete "1.0" 'end)
  117.     (editor-window 'insert "1.0" text)
  118.     (editor-window 'mark 'set 'insert "1.0")
  119.     ;; And now enhence it
  120.     (for-each (lambda (t) 
  121.         (do ((l (cadr t) (cddr l)))
  122.             ((null? l))
  123.           (if (eqv? (car t) 'underline)
  124.               (stk:set-underline editor-window (car l) (cadr l))
  125.               (stk:set-font editor-window (car t) (car l) (cadr l)))))
  126.           fmts))
  127.   (update))
  128.   
  129. (define (stk:write-file editor-window file)
  130.   (with-output-to-file file 
  131.     (lambda ()
  132.       (format #t ";;;; ~S\n" stk:STF-signature)
  133.       (format #t "~S\n" (stk:get-STF editor-window)))))
  134.  
  135.  
  136. (define (stk:write-file-ascii editor-window file)
  137.   (with-output-to-file file 
  138.     (lambda ()
  139.       (format #t "~A" (editor-window 'get "1.0" 'end)))))
  140.  
  141. (define (stk:read-file editor-window file)
  142.   (with-input-from-file file
  143.       (lambda ()
  144.     (let ((first-line (read-line)))
  145.       (if (string=? first-line (format #f ";;;; ~S" stk:STF-signature))
  146.           ;; File is a STF file
  147.           (stk:set-STF editor-window (read))
  148.           ;; File must be read as a "normal" file
  149.           (begin
  150.         (editor-window 'delete "1.0" 'end)
  151.         (do ((l first-line (read-line)))
  152.             ((eof-object? l))
  153.           (editor-window 'insert 'end l)
  154.           (editor-window 'insert 'end "\n"))
  155.         (editor-window 'mark 'set 'insert "1.0")))))))
  156.  
  157. (define (stk:get-filename toplevel) ; return the content of the file name  entry
  158.   (let ((entry (string->widget (& toplevel ".bt.e"))))
  159.     (entry 'get)))
  160.  
  161. (define (stk:set-filename toplevel filename)
  162.   (let ((entry (string->widget (& toplevel ".bt.e"))))
  163.     (entry 'delete 0 'end)
  164.     (entry 'insert 0 filename)))
  165.     
  166.  
  167. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  168. ;;;;
  169. ;;;; Interface
  170. ;;;;
  171. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  172.  
  173. (define (stk:make-editor name  . exit_code)
  174.   (let* ((top          (toplevel name))
  175.      (menu-bar   (frame     (& name ".mb") :bd 2 :relief "groove"))
  176.      (bottom     (frame     (& name ".bt")))
  177.      (text-area  (frame     (& name ".ta")))
  178.      (exit_code  (if (null? exit_code) `(destroy ,top) (car exit_code)))
  179.      (the-editor ()))
  180.  
  181.     ;;
  182.     ;; Window manager management
  183.     ;; 
  184.     (wm 'maxsize name 1000 800)
  185.     (wm 'protocol name "WM_DELETE_WINDOW" exit_code)
  186.     
  187.     ;;
  188.     ;; Text area frame
  189.     ;;
  190.     (pack [scrollbar (& text-area ".sc") :orient "vert" 
  191.                           :bd 2
  192.                      :relief "groove"
  193.                           :command (format #f "~A 'yview" 
  194.                               (& text-area ".ed"))]
  195.       :side "left" :fill "y")
  196.     (pack [text (& text-area ".ed") :padx 4 
  197.                     :pady 4
  198.                     :bd 2
  199.                     :wrap "word"
  200.                     :relief "groove"
  201.                     :yscroll (format #f "~A 'set"
  202.                              (& text-area ".sc"))]
  203.       :side "right" :expand #t :fill "both")
  204.  
  205.     (set! the-editor (string->widget (& text-area ".ed")))
  206.  
  207.     ;;
  208.     ;; Menu Creation
  209.     ;;
  210.  
  211.     (let* ((File (menubutton (& menu-bar ".file") 
  212.                  :text "File"
  213.                  :padx 10
  214.                  :menu (& menu-bar ".file.m")))
  215.        (m     (eval (menu (& menu-bar ".file.m")))))
  216.  
  217.       (m 'add 'command 
  218.           :label "  Read  "    
  219.           :command `(stk:read-file ,the-editor (stk:get-filename ,top)))
  220.       (m 'add 'command 
  221.           :label "  Save  "
  222.           :command `(stk:write-file ,the-editor (stk:get-filename ,top)))
  223.       (m 'add 'command 
  224.           :label "  Save Ascii  "
  225.           :command `(stk:write-file-ascii ,the-editor (stk:get-filename ,top)))
  226.       (m 'add 'separator)
  227.       (m 'add 'command :label "  Quit  " :command exit_code)
  228.       
  229.       (pack File :side "left"))
  230.  
  231.     (let* ((Font (menubutton (& menu-bar ".font")               
  232.                  :text "Font" 
  233.                  :padx 10
  234.                  :menu (& menu-bar ".font.m")))
  235.         (m    (eval (menu (& menu-bar ".font.m")))))
  236.  
  237.       (for-each (lambda(font)
  238.           (m 'add 'command 
  239.                    :label    (car font)
  240.               :font     (cadr font)
  241.               :command `(stk:fontify-selection ,the-editor
  242.                                ',(car font))))
  243.         stk:all-fonts)
  244.       (m 'add 'separator)
  245.       (m 'add 'command
  246.           :label "Underline"    
  247.           :command `(stk:underline-selection ,the-editor #t))
  248.       (m 'add 'command 
  249.           :label "No underline"
  250.           :command `(stk:underline-selection ,the-editor #f))
  251.  
  252.       (pack Font :side "left"))
  253.  
  254.     ;;
  255.     ;; Bottom frame
  256.     ;;
  257.     (pack [label (& bottom ".l") :text "File name" :padx 10] :side "left")
  258.     (pack [entry (& bottom ".e") :relief "ridge"] :side "left" :expand #t :fill "x")
  259.  
  260.     ;;
  261.     ;; Pack everybody
  262.     ;;
  263.     (pack menu-bar  :fill "x")
  264.     (pack text-area :expand #t :fill "both")
  265.     (pack bottom    :fill "x" :ipady 4 :ipadx 10)))
  266.  
  267.  
  268. ;; A simple editor accessible from prompt
  269. (define (ed . file)
  270.   (require "editor")
  271.   (let ((editor-name (gensym ".editor")))
  272.     (stk:make-editor editor-name)
  273.     (unless (null? file)
  274.        (stk:read-file (string->widget (& editor-name ".ta.ed")) (car file))
  275.        (stk:set-filename editor-name (car file)))))
  276.   
  277.