LispPlotter/plotter-compat.lisp at master · dbmcclain/LispPlotter · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

(in-package :plotter)

;; ------------------------------------------
;; Win32/OS X compatibility constants and functions
;; ------------------------------------------
(defun find-best-font (pane &key
                            (family "Times")
                            size
                            (weight :normal)
                            (slant  :roman))
  (gp:find-best-font (display-pane-of pane)
                     (gp:make-font-description
                      :family family
                      :size   #-:WIN32 size #+:WIN32 (round size)
                      :weight weight
                      :slant  slant)))

;; ------------------------------------------
#+:WIN32x
;; -- Under Windows/7+ we seem to not need this anymore...
;; DM/RAL  05/14
(defun adjust-linewidth (wd)
  ;; Win/XP can't handle fractional linewidths
  (max 1 (round wd)))

;; #-:WIN32
(defun adjust-linewidth (wd)
  ;; ... but Display PDF can...
  wd)

;; ------------------------------------------
(defun background-color (port)
  (gp:graphics-state-background
   (gp:get-graphics-state port)))

(defun foreground-color (port)
  (gp:graphics-state-foreground
   (gp:get-graphics-state port)))

#+:WIN32x
;; --- WE FINALLY HAVE DECENT ALPHA BLENDING ON WINDOW 7+ --
;; DM/RAL 05/14
(defun adjust-color (port color &optional alpha)
  ;; Win/XP can't handle true alpha blending. So we use a make-pretend system
  ;; that assumes the color will be blending with the background color. That only
  ;; works properly as long as the drawing is actually over that background color.
  (let* ((c (color:get-color-spec
             (color:unconvert-color
              port
              (color:convert-color port color))))
         (a (or alpha (color:color-alpha c))))
    (if (= 1 a)
      color
      (let* ((bg  (color:get-color-spec
                   (color:unconvert-color port
                                          (color:convert-color port
                                                               (background-color port)))))
             (1-a (- 1.0 a)))
        (labels ((mix (fn)
                   (+ (* 1-a (funcall fn bg))
                      (* a   (funcall fn c)))))
        (color:make-rgb
         (mix #'color:color-red)
         (mix #'color:color-green)
         (mix #'color:color-blue))
        )))))

;; #-:WIN32
(defun adjust-color (port color &optional alpha)
  ;; Mac OS/X Cocoa can do real alpha blending. Here we take the user's
  ;; requested color, and a possibly separate alpha level (alpha might be nil)
  ;; to produce a color that will be properly alpha blended over a varying background.
  (if (null alpha)
      color
    (let ((c (color:get-color-spec
              (color:unconvert-color port color))))
      (color:make-rgb
       (color:color-red   c)
       (color:color-green c)
       (color:color-blue  c)
       alpha)
      )))

#+:WIN32
(defun complementary-color (port color background)
  ;; produce a color such that XOR mode of that color against the background
  ;; will produce the requested color...
  (let* ((c  (color:get-color-spec
              (color:unconvert-color port color)))
         (bg (color:get-color-spec
              (color:unconvert-color port background))))

    (labels ((color-xor (compon1 compon2)
               (let ((icompon1  (round (* 255 compon1)))
                     (icompon2  (round (* 255 compon2))))
                 (/ (logxor icompon1 icompon2) 255.0)))

             (color-xor-components (fn)
               (color-xor (funcall fn c) (funcall fn bg))))

      (color:make-rgb
       (color-xor-components #'color:color-red)
       (color-xor-components #'color:color-green)
       (color-xor-components #'color:color-blue))
      )))

;; ------------------------------------------
#+:WIN32x
(defun adjust-box (box)
  ;; Win/XP can't handle fractional box coords
  (mapcar #'round box))

;; #-:WIN32
(defun adjust-box (box)
  ;; ... but OS/X Cocoa can...
  box)

;; ---------------------------------------------------------
;; WIN32 has some low-level pixmap routines that aren't reentrant
;; so we fix that up here by using our own lock to prevent multiple
;; threads from concurrent execution of those routines...

#+:WIN32
(defvar *win32-pixmap-lock* (mp:make-lock))

#+:WIN32
(defmacro create-pixmap-port (&rest args)
  `(mp:with-lock (*win32-pixmap-lock*)
     (gp:create-pixmap-port ,@args)))

#+:WIN32
(defmacro with-pixmap-graphics-port (args &body body)
  `(mp:with-lock (*win32-pixmap-lock*)
     (gp:with-pixmap-graphics-port ,args
       ,@body)))

#-:WIN32
(defmacro create-pixmap-port (&rest args)
  `(gp:create-pixmap-port ,@args))


#-:WIN32
(defmacro with-pixmap-graphics-port (args &body body)
  `(gp:with-pixmap-graphics-port ,args
     ,@body))