/collects/mrlib/private/aligned-pasteboard/snip-lib.rkt

http://github.com/gmarceau/PLT · Racket · 117 lines · 89 code · 13 blank · 15 comment · 19 complexity · adb1ee08bf606a7fc95d6abd75f75145 MD5 · raw file

  1. (module snip-lib mzscheme
  2. (require
  3. mzlib/class
  4. mzlib/etc
  5. mred
  6. mzlib/list
  7. mzlib/contract
  8. "interface.rkt")
  9. ;; a snip
  10. (define snip? (is-a?/c snip%))
  11. ;; a snip to act as the varying argument to a recursive functions
  12. (define linked-snip? (or/c snip? false/c))
  13. ;; a function to act on snips being mapped
  14. (define snip-visitor? any/c #;((snip?) (listof any/c) . ->* . (void)))
  15. ;; the rest of the lists passed to a snip mapping function
  16. (define rest-lists? (listof (listof any/c)))
  17. ;; a class that contains a snip
  18. (define editor? (is-a?/c editor<%>))
  19. (provide/contract
  20. (snip-width (snip? . -> . number?))
  21. (snip-height (snip? . -> . number?))
  22. (snip-min-width (snip? . -> . number?))
  23. (snip-min-height (snip? . -> . number?))
  24. (snip-parent (snip? . -> . (or/c editor? false/c)))
  25. (fold-snip ((snip? any/c . -> . any/c) any/c linked-snip? . -> . any/c))
  26. (for-each-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
  27. (map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c))))
  28. (stretchable-width? (snip? . -> . boolean?))
  29. (stretchable-height? (snip? . -> . boolean?)))
  30. ;; the width of a snip in the parent pasteboard
  31. (define (snip-width snip)
  32. (let ([left (box 0)]
  33. [right (box 0)]
  34. [pasteboard (snip-parent snip)])
  35. (send pasteboard get-snip-location snip left (box 0) false)
  36. (send pasteboard get-snip-location snip right (box 0) true)
  37. (- (unbox right) (unbox left))))
  38. ;; the height of a snip in the parent pasteboard
  39. (define (snip-height snip)
  40. (let ([top (box 0)]
  41. [bottom (box 0)]
  42. [pasteboard (snip-parent snip)])
  43. (send pasteboard get-snip-location snip (box 0) top false)
  44. (send pasteboard get-snip-location snip (box 0) bottom true)
  45. (- (unbox bottom) (unbox top))))
  46. ;; the minimum width of the snip
  47. (define (snip-min-width snip)
  48. (cond
  49. [(is-a? snip stretchable-snip<%>)
  50. (send snip get-aligned-min-width)]
  51. [else (snip-width snip)]))
  52. ;; the minimum height of the snip
  53. (define (snip-min-height snip)
  54. (cond
  55. [(is-a? snip stretchable-snip<%>)
  56. (send snip get-aligned-min-height)]
  57. [else (snip-height snip)]))
  58. ;; the pasteboard that contains the snip
  59. (define (snip-parent snip)
  60. (let ([admin (send snip get-admin)])
  61. (if admin
  62. (send admin get-editor)
  63. false)))
  64. ;; the application of f on all snips from snip to the end in a foldl foldr mannor
  65. (define (fold-snip f init-acc snip)
  66. (let loop ([snip snip]
  67. [acc init-acc])
  68. (cond
  69. [(is-a? snip snip%)
  70. (loop (send snip next) (f snip acc))]
  71. [else acc])))
  72. ;; applies the function to all the snips
  73. (define (for-each-snip f first-snip . init-lists)
  74. (let loop ([snip first-snip]
  75. [lists init-lists])
  76. (cond
  77. [(is-a? snip snip%)
  78. (apply f (cons snip (map first lists)))
  79. (loop (send snip next)
  80. (map rest lists))]
  81. [else (void)])))
  82. ;; a list of f applied to each snip
  83. (define (map-snip f first-snip . init-lists)
  84. (let loop ([snip first-snip]
  85. [lists init-lists])
  86. (cond
  87. [(is-a? snip snip%)
  88. (cons (apply f (cons snip (map first lists)))
  89. (loop (send snip next)
  90. (map rest lists)))]
  91. [else empty])))
  92. ;; true if the snip can be resized in the x dimention
  93. (define (stretchable-width? snip)
  94. (cond
  95. [(is-a? snip stretchable-snip<%>)
  96. (send snip stretchable-width)]
  97. [else false]))
  98. ;; true if the snip can be resized in the y dimention
  99. (define (stretchable-height? snip)
  100. (cond
  101. [(is-a? snip stretchable-snip<%>)
  102. (send snip stretchable-height)]
  103. [else false]))
  104. )