Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
C
clim-tos
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Alastair Bridgewater
clim-tos
Commits
3d78e246
Commit
3d78e246
authored
31 years ago
by
colin
Browse files
Options
Downloads
Patches
Plain Diff
fixed problem with gcontext clip mask not being updated when device region
changed
parent
40abc126
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
tk-silica/xt-graphics.lisp
+56
-47
56 additions, 47 deletions
tk-silica/xt-graphics.lisp
with
56 additions
and
47 deletions
tk-silica/xt-graphics.lisp
+
56
−
47
View file @
3d78e246
...
...
@@ -20,24 +20,24 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-graphics.lisp,v 1.
69
93/04/0
7 09:07:27 cer
Exp $
;; $fiHeader: xt-graphics.lisp,v 1.
70
93/04/0
8 13:19:15 colin
Exp $
(
in-package
:tk-silica
)
(
defclass
ink-gcontext
(
tk::gcontext
)
((
last-
device-
clip-region
:initform
nil
:fixed-index
2
)
((
last-clip-region
-tick
:initform
nil
:fixed-index
2
)
(
last-line-style
:initform
nil
:fixed-index
3
)
(
shift-tile-origin
:initform
nil
:fixed-index
4
)
(
ink-clip-region
:initform
nil
:fixed-index
5
)))
(
defmacro
ink-gcontext-last-
device-
clip-region
(
gcontext
)
(
defmacro
ink-gcontext-last-clip-region
-tick
(
gcontext
)
`
(
locally
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
excl::slot-value-using-class-name
'ink-gcontext
,
gcontext
'last-
device-
clip-region
)))
(
defsetf
ink-gcontext-last-
device-
clip-region
(
gcontext
)
(
value
)
'last-clip-region
-tick
)))
(
defsetf
ink-gcontext-last-clip-region
-tick
(
gcontext
)
(
value
)
`
(
locally
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
setf
(
excl::slot-value-using-class-name
'ink-gcontext
,
gcontext
'last-
device-
clip-region
)
'last-clip-region
-tick
)
,
value
)))
(
defmacro
ink-gcontext-last-line-style
(
gcontext
)
...
...
@@ -74,7 +74,8 @@
((
drawable
:initform
nil
)
(
ink-table
:initform
(
make-hash-table
:test
#'
equal
))
(
indirect-inks
:initform
nil
)
(
device-clip-region
:initform
nil
)))
(
device-clip-region
:initform
nil
)
(
device-clip-region-tick
:initform
0
)))
(
defmethod
make-medium
((
port
xt-port
)
sheet
)
(
make-instance
'xt-medium
...
...
@@ -264,14 +265,17 @@
;; 3. medium's sheet's device transformation changes
(
defun
medium-device-clip-region
(
medium
)
(
with-slots
(
sheet
device-clip-region
)
medium
(
or
device-clip-region
(
setf
device-clip-region
(
let
((
dr
(
sheet-device-region
sheet
))
(
mcr
(
medium-clipping-region
medium
)))
(
region-intersection
dr
(
transform-region
(
sheet-device-transformation
sheet
)
mcr
)))))))
(
with-slots
(
sheet
device-clip-region
device-clip-region-tick
)
medium
(
unless
device-clip-region
(
setf
device-clip-region
(
let
((
dr
(
sheet-device-region
sheet
))
(
mcr
(
medium-clipping-region
medium
)))
(
region-intersection
dr
(
transform-region
(
sheet-device-transformation
sheet
)
mcr
))))
(
incf
device-clip-region-tick
))
(
values
device-clip-region
device-clip-region-tick
)))
(
defmethod
(
setf
medium-clipping-region
)
:after
(
cr
(
medium
xt-medium
))
(
declare
(
ignore
cr
))
...
...
@@ -298,12 +302,15 @@
(
tk::widget-window
mirror
nil
))
(
defmethod
engraft-medium
:after
((
medium
xt-medium
)
(
port
xt-port
)
sheet
)
(
with-slots
(
indirect-inks
drawable
device-clip-region
)
(
with-slots
(
indirect-inks
drawable
device-clip-region
device-clip-region-tick
)
medium
(
let
((
palette
(
medium-palette
medium
)))
(
with-slots
(
white-pixel
black-pixel
)
palette
(
setf
indirect-inks
nil
device-clip-region
nil
)
(
setf
indirect-inks
nil
device-clip-region
nil
device-clip-region-tick
0
)
(
setf
(
medium-sheet
medium
)
sheet
)
(
when
(
and
drawable
(
not
(
eq
(
port-display
port
)
...
...
@@ -413,34 +420,36 @@
(
setf
(
ink-gcontext-last-line-style
gc
)
line-style
)))
;; clip mask
(
let
((
device-clip-region
(
medium-device-clip-region
medium
))
(
ink-clip-region
(
ink-gcontext-ink-clip-region
gc
)))
(
when
ink-clip-region
(
setq
device-clip-region
(
region-intersection
(
transform-region
(
make-translation-transformation
x-origin
y-origin
)
ink-clip-region
)
device-clip-region
)))
(
unless
(
eq
(
ink-gcontext-last-device-clip-region
gc
)
device-clip-region
)
(
setf
(
tk::gcontext-clip-mask
gc
)
(
macrolet
((
region-rectangle
(
region
)
`
(
with-bounding-rectangle*
(
left
top
right
bottom
)
,
region
(
list
(
fix-coordinate
left
)
(
fix-coordinate
top
)
(
fix-coordinate
(
-
right
left
))
(
fix-coordinate
(
-
bottom
top
))))))
(
etypecase
device-clip-region
(
everywhere
:none
)
(
nowhere
nil
)
(
standard-rectangle-set
(
let
((
regions
(
region-set-regions
device-clip-region
))
(
rectangles
nil
))
(
dolist
(
region
regions
)
(
push
(
region-rectangle
region
)
rectangles
))
rectangles
))
(
standard-bounding-rectangle
(
list
(
region-rectangle
device-clip-region
))))))
(
setf
(
ink-gcontext-last-device-clip-region
gc
)
device-clip-region
)))
(
let
((
ink-clip-region
(
ink-gcontext-ink-clip-region
gc
)))
(
multiple-value-bind
(
device-clip-region
device-clip-region-tick
)
(
medium-device-clip-region
medium
)
(
when
ink-clip-region
(
setq
device-clip-region
(
region-intersection
(
transform-region
(
make-translation-transformation
x-origin
y-origin
)
ink-clip-region
)
device-clip-region
)))
(
unless
(
and
(
eq
(
ink-gcontext-last-clip-region-tick
gc
)
device-clip-region-tick
)
(
null
ink-clip-region
))
(
setf
(
tk::gcontext-clip-mask
gc
)
(
macrolet
((
region-rectangle
(
region
)
`
(
with-bounding-rectangle*
(
left
top
right
bottom
)
,
region
(
list
(
fix-coordinate
left
)
(
fix-coordinate
top
)
(
fix-coordinate
(
-
right
left
))
(
fix-coordinate
(
-
bottom
top
))))))
(
etypecase
device-clip-region
(
everywhere
:none
)
(
nowhere
nil
)
(
standard-rectangle-set
(
let
((
regions
(
region-set-regions
device-clip-region
))
(
rectangles
nil
))
(
dolist
(
region
regions
)
(
push
(
region-rectangle
region
)
rectangles
))
rectangles
))
(
standard-bounding-rectangle
(
list
(
region-rectangle
device-clip-region
))))))
(
setf
(
ink-gcontext-last-clip-region-tick
gc
)
device-clip-region-tick
))))
;; tile and stipple origin
(
when
(
ink-gcontext-shift-tile-origin
gc
)
...
...
@@ -1396,7 +1405,7 @@
#+
ignore
(
setf
(
tk::gcontext-clip-mask
gcontext
)
pixmap
)
#+
ignore
(
set
f
(
ink-gcontext-last-
device-
clip-region
gcontext
)
nil
)
#+
ignore
(
dec
f
(
ink-gcontext-last-clip-region
-tick
gcontext
))
(
unless
start
(
setq
start
0
))
(
unless
end
(
setq
end
(
length
string
)))
...
...
@@ -1433,7 +1442,7 @@
(
3
(
values
(
-
x
ascent
)
(
-
y
pixmap-height
))))
(
setf
(
tk::gcontext-clip-mask
gcontext
)
string-pixmap
)
(
set
f
(
ink-gcontext-last-
device-
clip-region
gcontext
)
nil
)
(
dec
f
(
ink-gcontext-last-clip-region
-tick
gcontext
))
(
setf
(
tk::gcontext-clip-x-origin
gcontext
)
dst-x
(
tk::gcontext-clip-y-origin
gcontext
)
dst-y
)
(
tk::draw-rectangle
drawable
gcontext
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment