home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / scheme / text.scm < prev    next >
Text File  |  1995-08-02  |  3KB  |  111 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. ;;; Scrollable text widgets (only vertical scrollbar makes sense,
  4. ;;; since text can't be extended horizontally without changing the
  5. ;;; size of the top level window).
  6.  
  7. #|
  8. (define (make-scrollable-text . options)
  9.   (let ((text (apply make-text options))
  10.     (vscroll (make-scrollbar '(-orient vert))))
  11.     (let ((sb-command
  12.        (lambda ()
  13.          (ask-widget
  14.           vscroll
  15.           `(configure -command
  16.               ,(string-append (tk-widget->pathname text)
  17.                       " yview")))))
  18.       (c-command
  19.        (lambda ()
  20.          (ask-widget
  21.           text
  22.           `(configure -yscrollcommand
  23.               ,(string-append (tk-widget->pathname vscroll) " set"))))))
  24.       (defer text sb-command)
  25.       (defer vscroll c-command)
  26.       (make-hbox text vscroll))))
  27. |#
  28.  
  29. (define (make-scrollable-text . options)
  30.   (let ((text (apply make-text options))
  31.     (vscroll (make-scrollbar '(-orient vert))))
  32.     (let ((c-command
  33.        (lambda ()
  34.          (ask-widget
  35.           text
  36.           `(configure -yscrollcommand
  37.               ,(string-append (tk-widget->pathname vscroll) " set"))))))
  38.       (defer vscroll c-command)
  39.       (set-callback!
  40.        vscroll
  41.        (lambda (n)
  42.      (let ((n (string->number n)))
  43.        (ask-widget text `(yview -pickplace ,n)))))
  44.       (make-hbox text vscroll))))
  45.  
  46. (define (scrollable-text-text scrollable-text)
  47.   (car (box-children scrollable text)))
  48.  
  49. (define (scrollable-text-vscroll scrollable-text)
  50.   (cadr (box-children scrollable-text)))
  51.  
  52.  
  53.  
  54. ;;; Text has special protect-from-gc! procedures
  55.  
  56. (define (text-protect-from-gc! text stuff)
  57.   (let ((crud (crud-that-I-dont-want-to-gc-away text)))
  58.     (set-cdr! crud (cons stuff (cdr crud))))
  59.   'done)
  60.  
  61. (define (text-unprotect-from-gc! text stuff)
  62.   (let ((crud (crud-that-I-dont-want-to-gc-away text)))  
  63.     (set-cdr! crud (delq! stuff (cdr crud))))
  64.   'done)  
  65.  
  66. (define (text-flush-protect-list! text)
  67.   (let ((crud (crud-that-I-dont-want-to-gc-away text)))  
  68.     (set-cdr! crud '()))
  69.   'done)  
  70.  
  71.  
  72.  
  73. ;;; TextTags
  74.  
  75. (define (make-text-tag text index1 . index2)
  76.   (let ((name (tk-gen-name "texttag")))
  77.     (ask-widget text `(tag add ,name ,index1 ,@index2))
  78.     (let ((texttag (make-texttag texttag-ask-widget
  79.                  texttag-add-event-handler!
  80.                  'invalid
  81.                  name
  82.                  text
  83.                  '())))
  84.       (text-protect-from-gc! text texttag)
  85.       texttag)))
  86.  
  87. (define (texttag-add-event-handler! tag event handler substitutions)
  88.   (let ((text (TextTag.text tag))
  89.     (handler (proc-with-transformed-args handler substitutions)))
  90.     (set-texttag.callbacks! tag
  91.                 (cons handler (texttag.callbacks tag)))
  92.     (ask-widget text
  93.         `(tag bind
  94.           ,(TextTag.name tag)
  95.           ,event
  96.           ("SchemeCallBack" ,(object-hash handler *our-hash-table*)
  97.                     ,@substitutions)))))
  98.  
  99. (define (texttag-ask-widget tag arg-list)
  100.   (let* ((tag-name (TextTag.name tag))
  101.      (text     (TextTag.text tag))
  102.      (command  (car arg-list))
  103.      (new-arg-list (cons "tag"
  104.                  (cons command
  105.                    (cons tag-name (cdr arg-list))))))
  106.     (let ((result (ask-widget text new-arg-list)))
  107.       (if (eq? command 'delete)
  108.       (text-unprotect-from-gc! text tag))
  109.       result)))
  110.  
  111.