-
Notifications
You must be signed in to change notification settings - Fork 14
/
glop-win32.lisp
161 lines (138 loc) · 6.89 KB
/
glop-win32.lisp
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-
;;; GLOP implementation
(in-package #:glop)
(defun gl-get-proc-address (proc-name)
(glop-wgl:wgl-get-proc-address proc-name))
(defmethod list-video-modes ()
(glop-win32::list-video-modes))
(defmethod set-video-mode ((mode win32-video-mode))
(glop-win32::set-video-mode mode))
(defmethod current-video-mode ()
(glop-win32::current-video-mode))
(defstruct wgl-context
ctx)
;; FIXME: we should use specific context creation if available regardless of
;; :major and :minor being nil
(defmethod create-gl-context ((win win32-window) &key (make-current t) major minor
forward-compat debug
profile)
(let ((ctx (make-wgl-context)))
(setf (wgl-context-ctx ctx)
(if (and major minor)
(let ((attrs (list :major-version major :minor-version minor)))
(when profile
(case profile
(:core (push :core-profile-bit attrs))
(:compat (push :compatibility-profile-bit attrs)))
(push :profile-mask attrs))
(when (or forward-compat debug)
(let ((flags '()))
(when forward-compat (push :forward-compatible-bit flags))
(when debug (push :debug-bit flags))
(push flags attrs)
(push :flags attrs)))
(glop-wgl:wgl-create-specific-context (win32-window-dc win) attrs))
(glop-wgl:wgl-create-context (win32-window-dc win))))
(unless wgl-ctx
(format t "Error creating GL context: ~S~%" (glop-win32:get-last-error)))
(when make-current
(attach-gl-context win ctx))
(when (and major minor)
(glop-glx:correct-context? major minor))
ctx))
(defmethod destroy-gl-context ((ctx wgl-context))
(detach-gl-context ctx)
(glop-wgl:wgl-delete-context (wgl-context-ctx ctx)))
(defmethod attach-gl-context ((win win32-window) (ctx wgl-context))
(setf (window-gl-context win) ctx)
(glop-wgl:wgl-make-current (win32-window-dc win) (wgl-context-ctx ctx)))
(defmethod detach-gl-context ((ctx wgl-context))
(glop-wgl::wgl-make-current (cffi:null-pointer) (cffi:null-pointer)))
(defmethod open-window ((win win32-window) title width height &key (x 0) (y 0)
(rgba t)
(double-buffer t)
stereo
(red-size 4)
(green-size 4)
(blue-size 4)
(alpha-size 4)
(depth-size 16)
accum-buffer
(accum-red-size 0)
(accum-green-size 0)
(accum-blue-size 0)
stencil-buffer
(stencil-size 0))
(setf (win32-window-module-handle win)(glop-win32:get-module-handle (cffi:null-pointer)))
;; register window class
(glop-win32:create-and-register-class (win32-window-module-handle win) "GLOP-OpenGL")
(setf (win32-window-class-name win) "GLOP-OpenGL")
(let ((wnd (glop-win32:create-window-ex '(:ws-ex-app-window :ws-ex-window-edge)
"GLOP-OpenGL"
title
'(:ws-overlapped-window :ws-clip-siblings :ws-clip-children)
x y width height (cffi:null-pointer) (cffi:null-pointer)
(win32-window-module-handle win) (cffi:null-pointer))))
(unless wnd
(error "Can't create window (error ~S)~%" (glop-win32:get-last-error)))
(setf (win32-window-id win) wnd))
(%update-geometry win x y width height)
(setf (win32-window-dc win) (glop-win32:get-dc (win32-window-id win)))
;; FIXME: we need something easier to pass all attributes here
;; FIXME: use pixel format extensions if available
(setf (win32-window-pixel-format win) (glop-win32:choose-pixel-format
(win32-window-dc win)
:rgba rgba
:double-buffer double-buffer
:stereo stereo
:red-size red-size
:green-size green-size
:blue-size blue-size
:alpha-size alpha-size
:depth-size depth-size
:accum-buffer accum-buffer
:accum-red-size accum-red-size
:accum-green-size accum-green-size
:accum-blue-size accum-blue-size
:stencil-buffer stencil-buffer
:stencil-size stencil-size))
(glop-win32:set-foreground-window (win32-window-id win))
(glop-win32:update-window (win32-window-id win))
win)
(defmethod close-window ((win win32-window))
(glop-win32:destroy-window (win32-window-id win))
(glop-win32:unregister-class (win32-window-class-name win)
(win32-window-module-handle win)))
(defmethod set-fullscreen ((win win32-window) &optional (state (not (window-fullscreen win))))
(with-accessors ((id win32-window-id)
(fullscreen window-fullscreen))
win
(unless (eq state fullscreen)
(if state
(progn (glop-win32::%set-fullscreen (win32-window-id win) t)
(setf fullscreen t))
(progn (glop-win32::%set-fullscreen (win32-window-id win) nil)
(setf fullscreen nil))))
(glop-win32:update-window (win32-window-id win))
(show-window win)))
(defmethod set-geometry ((win win32-window) x y width height)
(glop-win32:set-geometry (win32-window-id win) x y width height)
(%update-geometry win x y width height))
(defmethod show-window ((win win32-window))
(glop-win32:show-window (win32-window-id win) :sw-show)
(glop-win32:set-focus (win32-window-id win)))
(defmethod hide-window ((win win32-window))
(glop-win32::show-window (win32-window-id win) :sw-hide))
(defmethod set-window-title ((win win32-window) title)
(setf (slot-value win 'title) title)
(glop-win32:set-window-text (win32-window-id win) title))
(defmethod swap-buffers ((win win32-window))
(glop-win32:swap-buffers (win32-window-dc win)))
(defmethod show-cursor ((win win32-window))
(glop-win32:show-cursor 1))
(defmethod hide-cursor ((win win32-window))
(glop-win32:show-cursor 0))
(defun %next-event (win &key blocking)
(let ((evt (glop-win32:next-event win (win32-window-id win) blocking)))
(setf glop-win32:%event% nil)
evt))