qfwfq/punctiform-convergence/snipets.scm

;; -*- mode: scheme -*-
;;
;; based on snip-lib from the embedded-gui collection

(module snipets mzscheme
  
  (require
   (lib "class.ss")
   (lib "etc.ss")
   (lib "mred.ss" "mred")
   (lib "list.ss")
   (lib "contract.ss"))
  
  ;; a snip
  (define snip? (is-a?/c snip%))
  ;; a snip to act as the varying argument to a recursive functions
  (define linked-snip? (union snip? false/c))
  ;; a function to act on snips being mapped
  (define snip-visitor? any/c #;((snip?) (listof any/c) . ->* . (void)))
  ;; the rest of the lists passed to a snip mapping function
  (define rest-lists? (listof (listof any/c)))
  ;; a class that contains a snip
  (define editor? (is-a?/c editor<%>))
  
  (provide/contract
   (snip-width (snip? . -> . number?))
   (snip-height (snip? . -> . number?))
   (snip-x (snip? . -> . number?))
   (snip-y (snip? . -> . number?))
   (snip-parent (snip? . -> . (union editor? false/c)))
   (fold-snip ((snip? any/c . -> . any/c) any/c linked-snip? . -> . any/c))
   (for-each-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
   (map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c)))))
  
  ;; the width of a snip in the parent pasteboard
  (define (snip-width snip)
    (let ([left (box 0)]
          [right (box 0)]
          [pasteboard (snip-parent snip)])
      (send pasteboard get-snip-location snip left (box 0) false)
      (send pasteboard get-snip-location snip right (box 0) true)
      (- (unbox right) (unbox left))))
    
  ;; the height of a snip in the parent pasteboard
  (define (snip-height snip)
    (let ([top (box 0)]
          [bottom (box 0)]
          [pasteboard (snip-parent snip)])
      (send pasteboard get-snip-location snip (box 0) top false)
      (send pasteboard get-snip-location snip (box 0) bottom true)
      (- (unbox bottom) (unbox top))))

  ;; the x-ccordinate of a snip in the parent pasteboard
  (define (snip-x snip)
    (let ([x (box 0)]
          [pasteboard (snip-parent snip)])
      (send pasteboard get-snip-location snip x (box 0) false)
      (unbox x)))

    ;; the y-ccordinate of a snip in the parent pasteboard
   (define (snip-y snip)
    (let ([y (box 0)]
          [pasteboard (snip-parent snip)])
      (send pasteboard get-snip-location snip (box 0) y false)
      (unbox y)))

;  ;; the minimum width of the snip
;  (define (snip-min-width snip)
;    (cond
;      [(is-a? snip stretchable-snip<%>)
;       (send snip get-aligned-min-width)]
;      [else (snip-width snip)]))
;  
;  ;; the minimum height of the snip
;  (define (snip-min-height snip)
;    (cond
;      [(is-a? snip stretchable-snip<%>)
;       (send snip get-aligned-min-height)]
;      [else (snip-height snip)]))
;  
  ;; the pasteboard that contains the snip
  (define (snip-parent snip)
    (let ([admin (send snip get-admin)])
      (if admin
          (send admin get-editor)
          false)))
  
  ;; the application of f on all snips from snip to the end in a foldl foldr mannor
  (define (fold-snip f init-acc snip)
    (let loop ([snip snip]
               [acc init-acc])
      (cond
        [(is-a? snip snip%)
         (loop (send snip next) (f snip acc))]
        [else acc])))
  
  ;; applies the function to all the snips
  (define (for-each-snip f first-snip . init-lists)
    (let loop ([snip first-snip]
               [lists init-lists])
      (cond
        [(is-a? snip snip%)
         (apply f (cons snip (map first lists)))
         (loop (send snip next)
               (map rest lists))]
        [else (void)])))
  
  ;; a list of f applied to each snip
  (define (map-snip f first-snip . init-lists)
    (let loop ([snip first-snip]
               [lists init-lists])
      (cond
        [(is-a? snip snip%)
         (cons (apply f (cons snip (map first lists)))
               (loop (send snip next)
                     (map rest lists)))]
        [else empty])))
  
;  ;; true if the snip can be resized in the x dimention
;  (define (stretchable-width? snip)
;    (cond
;      [(is-a? snip stretchable-snip<%>)
;       (send snip stretchable-width)]
;      [else false]))
;  
;  ;; true if the snip can be resized in the y dimention
;  (define (stretchable-height? snip)
;    (cond
;      [(is-a? snip stretchable-snip<%>)
;       (send snip stretchable-height)]
;      [else false]))
  )