nik gaffney
be217c70fb
all at a single point. almost instantly, expanding into scratches, eddies and snipets of layout algorithms. gradually reshaping, drawn with puctiform convergence. what did those Z'zus have hidden in their cupboard?
132 lines
4.2 KiB
Scheme
132 lines
4.2 KiB
Scheme
;; -*- 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]))
|
|
)
|