/[cello]/cello/clipping.lisp
ViewVC logotype

Contents of /cello/clipping.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Jun 5 01:47:49 2006 UTC (7 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +14 -20 lines
Beginnings only of merge with Celtk
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (defvar *render-clip-l*)
20 (defvar *render-clip-r*)
21 (defvar *render-clip-t*)
22 (defvar *render-clip-b*)
23
24 (defun ogl-is-enabled (key)
25 (not (zerop (gl-is-enabled key))))
26
27 (defun call-with-clipping (self clipped-fn)
28 (declare (ignorable self))
29 ;(funcall clipped-fn)
30
31 (if (not (clipped self))
32 (macrolet ((adj-unclipped (g p)
33 `(when ,g (- ,g (,p self)))))
34 (let ((*render-clip-l* (adj-unclipped *render-clip-l* px))
35 (*render-clip-r* (adj-unclipped *render-clip-r* px))
36 (*render-clip-t* (adj-unclipped *render-clip-t* py))
37 (*render-clip-b* (adj-unclipped *render-clip-b* py))
38 )
39 (funcall clipped-fn)))
40 (macrolet ((adj-clipped (mm g l p)
41 `(if ,g
42 (,mm (,l self)
43 (- ,g (,p self)))
44 (,l self))))
45 (let ((*render-clip-l* (adj-clipped max *render-clip-l* ll px))
46 (*render-clip-r* (adj-clipped min *render-clip-r* lr px))
47 (*render-clip-t* (adj-clipped downs-most *render-clip-t* lt py))
48 (*render-clip-b* (adj-clipped ups-most *render-clip-b* lb py))
49 )
50 (let* ((clip-restore0 (ix-clip self gl_clip_plane0 :xl (ll self)))
51 (clip-restore1 (ix-clip self gl_clip_plane1 :xr (lr self)))
52 (clip-restore2 (ix-clip self gl_clip_plane2 :yt (lt self)))
53 (clip-restore3 (ix-clip self gl_clip_plane3 :yb (lb self)))
54 (scissor-box (if (ogl-is-enabled gl_scissor_test)
55 (progn
56 (trc nil "NESTED scissor on" self)
57 (ogl-scissor-box))
58 (progn
59 (trc nil "toplevel scissor on" self)
60 (gl-enable gl_scissor_test)
61 nil))))
62 (trc nil "just clipped" self (ll self)(lr self)(lt self)(lb self))
63 (ix-clip-dump "just clipped dumped")
64 (count-it :ix-clipping)
65 (let* ((wbl (w-bottom-left self))
66 (sx (floor (v2-h wbl)))
67 (sy (floor (v2-v wbl)))
68 (sw (ceiling (l-width self)))
69 (sh (ceiling (l-height self))))
70 (gl-scissor sx sy sw sh)
71 (ogl::glec :scissor)
72 (trc nil "just scissored" :wbl wbl :sxy sx sy :swh sw sh)
73 ;(trc "...with rasterpos at" (ogl-raster-pos-get))
74 )
75 (prog1
76 (funcall clipped-fn)
77 (ix-clip-undo self gl_clip_plane0 clip-restore0)
78 (ix-clip-undo self gl_clip_plane1 clip-restore1)
79 (ix-clip-undo self gl_clip_plane2 clip-restore2)
80 (ix-clip-undo self gl_clip_plane3 clip-restore3)
81 (if scissor-box
82 (progn
83 (trc nil "restoring scissor" self (ogl-bounds scissor-box))
84 (apply 'gl-scissor (ogl-bounds scissor-box)))
85 (gl-disable gl_scissor_test))))))))
86
87 (defun ix-clip-undo (self p old-eqn)
88 (declare (ignorable self))
89 (if old-eqn
90 (progn
91 (trc nil "restoring anothers clip. me:" (md-name self) (eltd old-eqn 0)(eltd old-eqn 1)
92 (eltd old-eqn 2)(eltd old-eqn 3))
93 (gl-clip-plane p old-eqn)
94 (gl-enable p))
95 (gl-disable p)))
96
97 (defparameter *clipper* (make-ff-array gldouble 0 0 0 0))
98
99 (defun ix-clip-dump (msg)
100 msg
101 (trc nil "clipdump" msg
102 (maptimes (pn 4)
103 (when (ogl-get-boolean (+ gl_clip_plane0 pn))
104 (gl-get-clip-plane (+ gl_clip_plane0 pn) *clipper*)
105 (floor (eltd *clipper* 3))))))
106
107 (defun ix-clip (self p how eqn)
108 (declare (ignorable p self))
109 ;;
110 ;; A = y1 (z2 - z3) + y2 (z3 - z1) + y3 (z1 - z2)
111 ;; B = z1 (x2 - x3) + z2 (x3 - x1) + z3 (x1 - x2)
112 ;; C = x1 (y2 - y3) + x2 (y3 - y1) + x3 (y1 - y2)
113 ;; - D = x1 (y2 z3 - y3 z2) + x2 (y3 z1 - y1 z3) + x3 (y1 z2 - y2 z1)
114 ;;
115 (let ((x1 0)(y1 0)(z1 0)(x2 0)(y2 0)(z2 0)(x3 0)(y3 0)(z3 0) old-eqn)
116 ;
117 ; get current clip this plane if any for restore by caller
118 ;
119 #+no (when (ogl-get-boolean p)
120 (setf old-eqn (make-ff-array gldouble 0 0 0 0))
121 (gl-get-clip-plane p old-eqn)
122 (trc nil "saving anothers clip. me:" self (eltd old-eqn 0)(eltd old-eqn 1)
123 (eltd old-eqn 2)(eltd old-eqn 3)))
124
125 (ecase how
126 (:xl (setq x1 eqn x2 eqn x3 eqn)
127 (setq y2 1 y3 1)
128 (setq z3 (nearer 1)))
129 (:xr (setq x1 eqn x2 eqn x3 eqn)
130 (setq y2 1 y3 1)
131 (setq z3 (farther 1)))
132 (:yt (setq y1 eqn y2 eqn y3 eqn)
133 (setq x2 1 x3 1)
134 (setq z3 (nearer 1)))
135 (:yb (setq y1 (+ eqn) y2 (+ eqn) y3 (+ eqn))
136 (setq x2 1 x3 1)
137 (setq z3 (farther 1))))
138
139 (setf (eltd *clipper* 0)
140 (+ (* y1 (- z2 z3)) (* y2 (- z3 z1)) (* y3 (- z1 z2))))
141
142 (setf (eltd *clipper* 1)
143 (+ (* z1 (- x2 x3)) (* z2 (- x3 x1)) (* z3 (- x1 x2))))
144
145 (setf (eltd *clipper* 2)
146 (+ (* x1 (- y2 y3)) (* x2 (- y3 y1)) (* x3 (- y1 y2))))
147
148 ;; - D = x1 (y2 z3 - y3 z2) + x2 (y3 z1 - y1 z3) + x3 (y1 z2 - y2 z1)
149 ;;; (trc "clipping :x1" x1 :y1 y1 :z1 z1)
150 ;;; (trc "clipping :x2" x2 :y2 y2 :z2 z2)
151 ;;; (trc "clipping :x3" x3 :y3 y3 :z3 z3)
152 (setf (eltd *clipper* 3)
153 (- (+ (* x1 (- (* y2 z3) (* y3 z2)))
154 (* x2 (- (* y3 z1) (* y1 z3)))
155 (* x3 (- (* y1 z2) (* y2 z1))))))
156
157 (trc nil "clipping myself:" self :plane (- p gl_clip_plane0)
158 (eltd *clipper* 0)(eltd *clipper* 1)
159 (eltd *clipper* 2)(eltd *clipper* 3))
160
161 (progn
162 (gl-clip-plane p *clipper*)
163 #+nah (progn
164 (gl-get-clip-plane p *clipper*)
165 (trc "ix-clip just set/read" test (floor (eltd *clipper* 3))))
166 (gl-enable p))
167
168 old-eqn))

  ViewVC Help
Powered by ViewVC 1.1.5