PageRenderTime 48ms CodeModel.GetById 24ms RepoModel.GetById 0ms app.codeStats 0ms

/region.lisp

http://github.com/pyb/zen
Lisp | 244 lines | 149 code | 21 blank | 74 comment | 0 complexity | 2d322159615e488a00876a5630fb632c MD5 | raw file
Possible License(s): GPL-3.0
  1. ;; (C) 2011 Pierre-Yves Baccou
  2. ;; Simplifed implementation of regions inspired by this : (see miregion.c in XOrg server)
  3. ;; ----------------------------------------------------------------------------
  4. ;; Copyright 1987, 1988, 1989, 1998 The Open Group
  5. ;; Copyright 1987, 1988, 1989 by
  6. ;; Digital Equipment Corporation, Maynard, Massachusetts.
  7. ;; and the Massachusetts Institute of Technology, Cambridge, Massachusetts
  8. ;; The functions in this file implement the Region abstraction used extensively
  9. ;; throughout the X11 sample server. A Region is simply a set of disjoint
  10. ;; (non-overlapping) rectangles, plus an "extent" rectangle which is the
  11. ;; smallest single rectangle that contains all the non-overlapping rectangles.
  12. ;;
  13. ;; A Region is implemented as a "y-x-banded" array of rectangles. This array
  14. ;; imposes two degrees of order. First, all rectangles are sorted by top side
  15. ;; y coordinate first (y1), and then by left side x coordinate (x1).
  16. ;;
  17. ;; Furthermore, the rectangles are grouped into "bands". Each rectangle in a
  18. ;; band has the same top y coordinate (y1), and each has the same bottom y
  19. ;; coordinate (y2). Thus all rectangles in a band differ only in their left
  20. ;; and right side (x1 and x2). Bands are implicit in the array of rectangles:
  21. ;; there is no separate list of band start pointers.
  22. ;;
  23. ;; The y-x band representation does not minimize rectangles. In particular,
  24. ;; if a rectangle vertically crosses a band (the rectangle has scanlines in
  25. ;; the y1 to y2 area spanned by the band), then the rectangle may be broken
  26. ;; down into two or more smaller rectangles stacked one atop the other.
  27. ;;
  28. ;; ----------- -----------
  29. ;; | | | | band 0
  30. ;; | | -------- ----------- --------
  31. ;; | | | | in y-x banded | | | | band 1
  32. ;; | | | | form is | | | |
  33. ;; ----------- | | ----------- --------
  34. ;; | | | | band 2
  35. ;; -------- --------
  36. ;;
  37. ;; An added constraint on the rectangles is that they must cover as much
  38. ;; horizontal area as possible: no two rectangles within a band are allowed
  39. ;; to touch.
  40. ;;
  41. ;; Whenever possible, bands will be merged together to cover a greater vertical
  42. ;; distance (and thus reduce the number of rectangles). Two bands can be merged
  43. ;; only if the bottom of one touches the top of the other and they have
  44. ;; rectangles in the same places (of the same width, of course).
  45. ;; ----------------------------------------------------------------------------
  46. ;; zen regions are a lot simpler. They are just a list of rects (without extents)
  47. ;; rectangle = list : (x1 y1 x2 y2) aka (l top r bot). Note top < bot because of X's coordinate system.
  48. ;; have a library ? region:complement region:add-rect etc would be nicer ?
  49. (provide "region")
  50. (load "util/util")
  51. (flet ((top (rect)
  52. (second rect))
  53. (bot (rect)
  54. (fourth rect))
  55. (l (rect)
  56. (first rect))
  57. (r (rect)
  58. (third rect)))
  59. ;
  60. ;; horizontal cut, always returns a list of rectangles.
  61. (defun cut (rect y)
  62. (bind (l top r bot)
  63. rect
  64. (if (not (< top y bot))
  65. (list rect)
  66. (list (list l top r y)
  67. (list l y r bot)))))
  68. ;
  69. (defun coalesce-band (rects)
  70. (when rects
  71. (bind (l top r bot)
  72. (first rects)
  73. (cond ((null (rest rects))
  74. rects)
  75. ((< r
  76. (l (second rects)))
  77. (list* (first rects)
  78. (coalesce-band (rest rects))))
  79. ((>= r
  80. (r (second rects)))
  81. (list* (first rects)
  82. (coalesce-band (cddr rects))))
  83. (t
  84. (coalesce-band (list* (list l
  85. top
  86. (r (second rects))
  87. bot)
  88. (cddr rects))))))))
  89. ;; doc : p = first rectangle whose top line is not level with the first
  90. ;; : q = first rectangle not in a band together with the first.
  91. ;; I should probably rename p <-> q so as to put the most 'specific' first
  92. (defun coalesce (rects)
  93. (when rects
  94. (bind (l1 top1 r1 bot1)
  95. (first rects)
  96. (let ((p (position-if-not #'(lambda (rect)
  97. (= top1 (top rect)))
  98. rects))
  99. (q (position-if-not #'(lambda (rect)
  100. (and (= top1 (top rect))
  101. (= bot1 (bot rect))))
  102. rects)))
  103. (cond ((null q) ; we have a perfect band
  104. (coalesce-band rects))
  105. ((<= bot1 ; we have a standalone band (of one or many rects)
  106. (top (elt rects q)))
  107. (nconc (coalesce-band (subseq rects
  108. 0
  109. q))
  110. (coalesce (subseq rects
  111. q))))
  112. ((and p
  113. (= 1 p)) ; no others at same top level
  114. (bind (rect-top rect-bot)
  115. (cut (first rects)
  116. (top (second rects)))
  117. (list* rect-top
  118. (coalesce (sort-rects (list* rect-bot
  119. (rest rects)))))))
  120. (t (let ((next-highest-line (if p
  121. (min (top (elt rects
  122. p))
  123. (bot (first rects)))
  124. (bot (first rects)))))
  125. (coalesce (sort-rects (mapcan (rcurry #'cut
  126. next-highest-line)
  127. rects))))))))))
  128. (defun sort-rects (rects)
  129. (sort rects #'(lambda (rect1 rect2)
  130. (bind (l1 top1 r1 bot1)
  131. rect1
  132. (bind (l2 top2 r2 bot2)
  133. rect2
  134. (cond ((< top1 top2) t)
  135. ((> top1 top2) nil)
  136. ((< bot1 bot2) t)
  137. ((> bot1 bot2) nil)
  138. ((< l1 l2) t)
  139. ((> l1 l2) nil)
  140. ((< r1 r2) t)
  141. ((> r1 r2) nil)))))))
  142. (defun rect-intersection (rect1 rect2)
  143. (declare (list rect1 rect2))
  144. (bind (l1 top1 r1 bot1)
  145. rect1
  146. (declare (fixnum l1 top1 r1 bot1))
  147. (bind (l2 top2 r2 bot2)
  148. rect2
  149. (declare (fixnum l2 top2 r2 bot2))
  150. (unless (or (>= l2 r1)
  151. (>= l1 r2)
  152. (>= top2 bot1)
  153. (>= top1 bot2))
  154. (list (max l1 l2)
  155. (max top1 top2)
  156. (min r1 r2)
  157. (min bot1 bot2))))))
  158. (defun degenerate? (rect)
  159. (declare (list rect))
  160. (bind (l top r bot)
  161. rect
  162. (declare (fixnum l top r bot))
  163. (or (= l r)
  164. (= top bot))))
  165. (defun remove-rects (rect rects)
  166. "remove from rect the intersection between rect and rects"
  167. (declare (inline degenerate?))
  168. (acond ((null rects)
  169. (list rect))
  170. ((rect-intersection rect
  171. (first rects))
  172. (bind (li topi ri boti)
  173. it
  174. (bind (l top r bot)
  175. rect
  176. (mapcan (rcurry #'remove-rects
  177. (rest rects))
  178. (remove-if #'degenerate?
  179. `((,l ,top ,r ,topi)
  180. (,l ,topi ,li ,boti)
  181. (,ri ,topi ,r ,boti)
  182. (,l ,boti ,r ,bot)))))))
  183. (t
  184. (remove-rects rect
  185. (rest rects)))))
  186. ;; What was the sorting for ?
  187. ;;(defun region-difference (rects1 rects2)
  188. ;; (sort-rects (mapcan (rcurry #'remove-rects
  189. ;; rects2)
  190. ;; rects1)))
  191. (defun region-difference (rects1 rects2)
  192. "What's in region 1 and not in region 2?"
  193. (mapcan (rcurry #'remove-rects
  194. rects2)
  195. rects1))
  196. (defun shift-region (dx dy rects)
  197. (mapcar #'(lambda (rect)
  198. (bind (x1 y1 x2 y2)
  199. rect
  200. (list (+ x1 dx) (+ y1 dy) (+ x2 dx) (+ y2 dy))))
  201. rects))
  202. (defun extents (rects)
  203. (let ((ex1 (apply #'min (mapcar #'first rects)))
  204. (ey1 (apply #'min (mapcar #'second rects)))
  205. (ex2 (apply #'max (mapcar #'third rects)))
  206. (ey2 (apply #'max (mapcar #'fourth rects))))
  207. (list ex1 ex2 ey1 ey2)))
  208. ;
  209. ) ; flet (top bot l r)
  210. #|
  211. ;; If I ever go back to XOrg-type regions...
  212. (defun add-rect (rect region)
  213. (bind (x1 y1 x2 y2)
  214. rect
  215. (bind (ex1 ey1 ex2 ey2) ; extents
  216. (first region)
  217. (list* (list (min x1 ex1)
  218. (min y1 ey1)
  219. (max x2 ex2)
  220. (max y2 ey2)) ; new extents
  221. rect
  222. (rest region)))))
  223. |#