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 / canvas.scm < prev    next >
Text File  |  1995-08-02  |  10KB  |  282 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. ;;; Canvases can be scrollable: we can create them with two scrollbars,
  4. ;;; one on the right and one on the bottom.
  5.  
  6. (define (make-scrollable-canvas . options)
  7.   (let ((canvas (apply make-canvas options))
  8.     (vscroll (make-scrollbar '(-orient vert)))
  9.     (hscroll (make-scrollbar '(-orient horiz))))
  10.     (let ((v-command
  11.        (lambda ()
  12.          (ask-widget
  13.           vscroll
  14.           `(configure -command
  15.               ,(string-append (tk-widget->pathname canvas) " yview")))))
  16.       (h-command
  17.        (lambda ()
  18.          (ask-widget
  19.           hscroll
  20.           `(configure -command
  21.               ,(string-append (tk-widget->pathname canvas) " xview")))))
  22.       (c-command
  23.        (lambda ()
  24.          (maybe-defer
  25.           vscroll
  26.           (lambda ()
  27.         (ask-widget
  28.          canvas
  29.          `(configure
  30.                    -xscroll
  31.                ,(string-append (tk-widget->pathname hscroll) " set")
  32.                    -yscroll
  33.            ,(string-append (tk-widget->pathname vscroll) " set"))))))))
  34.       (defer canvas v-command)
  35.       (defer canvas h-command)
  36.       (defer hscroll c-command)
  37.       (make-vbox (make-hbox canvas vscroll) hscroll))))
  38.  
  39. (define (scrollable-canvas-canvas scrollable-canvas)
  40.   (let ((top-row (car (box-children scrollable-canvas))))
  41.     (car (box-children top-row))))
  42.  
  43. (define (scrollable-canvas-vscroll scrollable-canvas)
  44.   (let ((top-row (car (box-children scrollable-canvas))))
  45.     (cadr (box-children top-row))))
  46.  
  47. (define (scrollable-canvas-hscroll scrollable-canvas)
  48.   (cadr (box-children scrollable-canvas)))
  49.  
  50.  
  51. ;;; Canvas has special protect-from-gc! procedures
  52.  
  53. (define (canvas-protect-from-gc! canvas stuff)
  54.   (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
  55.     (set-cdr! crud (cons stuff (cdr crud))))
  56.   'done)
  57.  
  58. (define (canvas-unprotect-from-gc! canvas stuff)
  59.   (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))  
  60.     (set-cdr! crud (delq! stuff (cdr crud))))
  61.   'done)  
  62.  
  63. (define (canvas-flush-protect-list! canvas)
  64.   (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))  
  65.     (set-cdr! crud '()))
  66.   'done)  
  67.  
  68.  
  69. ;;; CanvasItem structure
  70.  
  71. (define (make-canvas-item name canvas)
  72.   (if (not (TKWidget%.handle canvas))
  73.       (error "You must OPEN the canvas before you can make an item on it"))
  74.   (let ((item (make-canvasitem canvasitem-ask-widget
  75.                    canvasitem-add-event-handler!
  76.                    'invalid
  77.                    name
  78.                    canvas
  79.                    '())))
  80.     (canvas-protect-from-gc! canvas item)
  81.     item))
  82.  
  83. (define (canvasitem-add-event-handler! item event handler substitutions)
  84.   (let ((canvas (CanvasItem.canvas item))
  85.     (handler (proc-with-transformed-args handler substitutions)))
  86.     (set-canvasitem.%binding-callbacks!
  87.      item
  88.      (cons handler (canvasitem.%binding-callbacks item)))
  89.     (ask-widget canvas
  90.         `(bind
  91.           ,(CanvasItem.name item)
  92.           ,event
  93.           ("SchemeCallBack" ,(hash handler *our-hash-table*)
  94.                     ,@substitutions)))))
  95.  
  96. ;;; The following assumes that the commands which explicitly mention
  97. ;;; canvas items mention them only as their second argument. This is
  98. ;;; true for most of the commands (e.g., itemconfigure, move, raise);
  99. ;;; but select, for example, is an exception. Do we care about those,
  100. ;;; anyway?  Same is true for the <CanvasItemGroup> version.
  101.  
  102. (define (canvasitem-ask-widget me arg-list)
  103.   (let* ((name   (CanvasItem.name  me))
  104.      (canvas (CanvasItem.canvas me))
  105.      (command (car arg-list))
  106.      (new-arg-list (cons (if (eq? command 'configure)
  107.                  'itemconfigure
  108.                  command)
  109.                  (cons name (cdr arg-list)))))
  110.     (let ((result (ask-widget canvas new-arg-list)))
  111.       (if (eq? command 'delete)
  112.       (canvas-unprotect-from-gc! canvas me))
  113.       result)))
  114.  
  115.  
  116. ;;; CanvasItemGroup structure, for grouping (tagging) canvas items together.
  117.  
  118. (define (make-canvas-item-group canvas list-of-canvas-items)
  119.   (let ((tag (tk-gen-name "CanvasItemGroup")))
  120.     (for-each (lambda (item)
  121.         (if (eq? canvas (CanvasItem.canvas item))
  122.             (ask-widget item `(configure -tags ,tag))
  123.             (error "MAKE-CANVAS-ITEM-GROUP: not a canvas item on canvas"
  124.                canvas item)))
  125.           list-of-canvas-items)
  126.     (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
  127.                          CanvasItemGroup-add-event-handler!
  128.                          'invalid
  129.                          tag
  130.                          canvas
  131.                          '())))
  132.       (canvas-protect-from-gc! canvas CanvasItemGroup)
  133.       CanvasItemGroup)))
  134.  
  135.  
  136. (define (add-to-canvas-item-group tag new-item)
  137.   (if (eq? (CanvasItem.canvas new-item)
  138.        (CanvasItemGroup.canvas tag))
  139.       (ask-widget new-item `(configure -tags ,(CanvasItemGroup.tag tag)))
  140.       (error "ADD-TO-CANVAS-ITEM-GROUP: not a canvas item on canvas"
  141.          canvas new-item)))
  142.  
  143. (define (merge-canvas-item-groups canvas destructive? . tags)
  144.   (let ((new-tag (tk-gen-name "CanvasItemGroup")))
  145.     (for-each
  146.      (lambda (tag)
  147.        (cond ((eq? (CanvasItemGroup.canvas tag) canvas)
  148.           (let ((tk-tag (CanvasItemGroup.tag tag)))
  149.         (ask-widget canvas `(addtag ,new-tag withtag ,tk-tag))
  150.         ;; If destructive? is true, the old tags are
  151.         ;; destroyed. Otherwise, they are kept. The old tags
  152.         ;; take precedence in case of conflicting event handlers. 
  153.         (if destructive?
  154.             (begin
  155.               (ask-widget canvas `(dtag ,tk-tag))
  156.               (canvas-unprotect-from-gc! canvas tag)))))
  157.          (else
  158.           (error "MERGE-CANVAS-ITEM-GROUPS: not a canvas tag on canvas"
  159.              canvas tag))))
  160.      tags)
  161.     (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
  162.                      CanvasItemGroup-add-event-handler!
  163.                      'invalid
  164.                      new-tag
  165.                      canvas
  166.                      '())))
  167.       (canvas-protect-from-gc! canvas CanvasItemGroup)
  168.       CanvasItemGroup)))
  169.  
  170. (define (CanvasItemGroup-add-event-handler! tag event handler substitutions)
  171.   ;; to handle tagged canvas items
  172.   (let ((canvas (CanvasItemGroup.canvas tag))
  173.     (handler (proc-with-transformed-args handler substitutions)))
  174.     (set-CanvasItemGroup.%binding-callbacks!
  175.      tag
  176.      (cons handler (CanvasItemGroup.%binding-callbacks tag)))
  177.     (ask-widget canvas
  178.         `(bind
  179.           ,(CanvasItemGroup.tag tag)
  180.           ,event
  181.           ("SchemeCallBack" ,(hash handler *our-hash-table*)
  182.                     ,@substitutions)))))
  183.  
  184. (define (CanvasItemGroup-ask-widget tag arg-list)
  185.   ;; to handle tagged canvas items
  186.   (let* ((tag-name (CanvasItemGroup.tag    tag))
  187.      (canvas   (CanvasItemGroup.canvas tag))
  188.      (command  (car arg-list))
  189.      (new-arg-list (cons (if (eq? command 'configure)
  190.                  'itemconfigure
  191.                  command)
  192.                  (cons tag-name (cdr arg-list)))))
  193.     (let ((result (ask-widget canvas new-arg-list)))
  194.       (if (eq? command 'delete)
  195.       (canvas-unprotect-from-gc! canvas tag))
  196.       result)))
  197.  
  198.  
  199. ;;; This is how the user creates canvas items, e.g.
  200. ;;; (define george (make-arc-on-canvas c 200 200 250 250))
  201.  
  202. (define (make-arc-on-canvas canvas x1 y1 x2 y2 . options)
  203.   (let ((configure-options (if (null? options) '() (car options))))
  204.     (make-canvas-item
  205.      (ask-widget canvas `(create arc ,x1 ,y1 ,x2 ,y2 ,@configure-options))
  206.      canvas)))
  207.  
  208. (define (make-bitmap-on-canvas canvas bitmap-filename-string x y . options)
  209.   (if (not (file-exists? bitmap-filename-string))
  210.       (error "MAKE-BITMAP-ON-CANVAS: Bad file name" bitmap-filename-string))
  211.   (let ((configure-options (if (null? options) '() (car options))))
  212.     (make-canvas-item
  213.      (ask-widget canvas
  214.          `(create bitmap ,x ,y
  215.               -bitmap ,(string-append "@" bitmap-filename-string)
  216.               ,@configure-options))
  217.      canvas)))
  218.     
  219. (define (make-line-on-canvas canvas x1 y1 x2 y2 . opt-args)
  220.   (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
  221.     (if (null? opt-args)
  222.     (if (odd? (length xy-list))
  223.         (error "MAKE-LINE:  Missing a y coordinate"
  224.            (append (list x1 y1 x2 y2) xy-list))
  225.         (make-canvas-item
  226.          (ask-widget canvas `(create line ,x1 ,y1 ,x2 ,y2 ,@xy-list
  227.                      ,@configure-options))
  228.          canvas))
  229.     (let ((next-arg (car opt-args)))
  230.       (if (list? next-arg)
  231.           (loop (cdr opt-args) xy-list next-arg)
  232.           (loop (cdr opt-args)
  233.             (append xy-list (list next-arg))
  234.             configure-options))))))
  235.  
  236. (define (make-oval-on-canvas canvas x1 y1 x2 y2 . options)
  237.   (let ((configure-options (if (null? options) '() (car options))))
  238.     (make-canvas-item
  239.      (ask-widget canvas `(create oval ,x1 ,y1 ,x2 ,y2 ,@configure-options))
  240.      canvas)))
  241.  
  242. (define (make-polygon-on-canvas canvas x1 y1 x2 y2 x3 y3 . opt-args)
  243.   (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
  244.     (if (null? opt-args)
  245.     (if (odd? (length xy-list))
  246.         (error "MAKE-POLYGON:  Missing a y coordinate"
  247.            (append (list x1 y1 x2 y2 x3 y3) xy-list))
  248.         (make-canvas-item
  249.          (ask-widget canvas `(create polygon ,x1 ,y1 ,x2 ,y2 ,x3 ,y3
  250.                      ,@xy-list ,@configure-options))
  251.          canvas))
  252.     (let ((next-arg (car opt-args)))
  253.       (if (list? next-arg)
  254.           (loop (cdr opt-args) xy-list next-arg)
  255.           (loop (cdr opt-args)
  256.             (append xy-list (list next-arg))
  257.             configure-options))))))
  258.  
  259. (define (make-rectangle-on-canvas canvas x1 y1 x2 y2 . options)
  260.   (let ((configure-options (if (null? options) '() (car options))))
  261.     (make-canvas-item
  262.      (ask-widget canvas `(create rectangle ,x1 ,y1 ,x2 ,y2 ,@configure-options))
  263.      canvas)))
  264.  
  265. (define (make-text-on-canvas canvas x y . options)
  266.   (let ((configure-options (if (null? options) '() (car options))))
  267.     (make-canvas-item
  268.      (ask-widget canvas `(create text ,x ,y ,@configure-options))
  269.      canvas)))
  270.  
  271. (define (make-widget-on-canvas canvas widget x y . options)
  272.   (let ((configure-options (if (null? options) '() (car options))))
  273.     (add-child! canvas widget)
  274.     (make-canvas-item
  275.      (ask-widget
  276.       canvas
  277.       `(create window ,x ,y
  278.            -window ,(lambda () (tk-widget->pathname widget))
  279.            ,@configure-options))
  280.      canvas)))
  281.  
  282.