├── .gitignore ├── LICENSE ├── README.md ├── constants.lisp ├── examples ├── climage │ └── climage.lisp ├── console │ └── console.lisp ├── dialogs │ └── dialogs.lisp ├── dragdrop │ └── dragdrop.lisp ├── dragons │ └── dragons.lisp ├── icon │ └── icon.lisp ├── macroman │ └── macroman.lisp ├── minesweeper │ └── minesweeper.lisp ├── pong │ └── pong.lisp ├── printer │ └── printer.lisp ├── rpc │ └── rpc.lisp ├── scrollbar │ └── scrollbar.lisp ├── tetris │ └── tetris.lisp ├── treeview │ └── treeview.lisp ├── turtle │ └── turtle.lisp └── zetcode │ ├── zetcode.lisp │ └── zetcode.txt ├── ffi.lisp ├── ftw.asd ├── ftw.lisp └── package.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | ## ignore emacs tmp files and fasls 3 | *.fasl 4 | *.lisp~ 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Frank James 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # FTW - Common Lisp For the Win(32) 3 | 4 | # 1. Introduction 5 | This library provides a very thin interface to the underlying 6 | APIs for writing native Windows GUIs in Common Lisp. 7 | 8 | The intention is to be able to write the same sort of codes in Lisp as you 9 | would if writing normal Win32 GUIs in C. This also opens the possibility 10 | for writing other more general graphical applications like games. 11 | 12 | # 2. Functions 13 | All underlying Win32 functions have Lisp equivalents, mostly with CamelCase replaced with the Lisp style kebab-case. 14 | 15 | Because this is a very thin wrapper over the top of the underlying Win32 API, 16 | it is assumed the user is at least familiar with the equivalent C programming. 17 | Documentation for each of the functions can be found on MSDN or any of 18 | the other C language resource. 19 | 20 | ## 2.1 Limitations 21 | Several functions accept IDs for so called "resources", which normally get linked 22 | in with the object code by the resource compiler (when writing in C). For 23 | obviously reasons this is not possible when using Lisp. 24 | 25 | ## 2.2 Other platforms 26 | This is a Windows only library and does not work on any other platform. 27 | It is not a cross platform GUI library. 28 | 29 | 30 | # 3. Extra utilities 31 | Several extra functions and macros are provided which the author has found useful. 32 | These are found in ftw.lisp. 33 | 34 | ## 3.1 Constants 35 | To use the Win32 API you need access to a vast number of predefined constants. 36 | These are defined in constants.lisp. Rather than export each of these symbols from 37 | the FTW package the programmer has two options: either access directly 38 | or use the macros `const` or `logior-consts`: 39 | ``` 40 | ;; directly 41 | ftw::+fred+ 42 | (logior ftw::+fred+ ftw::+jim+) 43 | ;; sugar coating macro 44 | (ftw:const +fred+) 45 | (ftw:logior-consts +fred+ +jim+) 46 | ``` 47 | 48 | The macro `CONST` takes a string designator and converts to the symbol with that name in the `FTW` package. 49 | In many places you need to pass a bitmask of logical-OR of several flags, use `LOGIOR-CONSTS` for this 50 | which performs the same transformation. 51 | 52 | Note that there are possibly many constants which have not been defined in constants.lisp. These should be added over time as they become useful. 53 | 54 | ## 3.2 Resources 55 | When writing Win32 programs in the C programming language it is common to embed binary resources such 56 | as icons, cursors and bitmaps using the resource compiler. These can then be referenced by an integer 57 | ID from various Win32 calls. This is not possible when calling these functions at from Lisp because 58 | we have to do everthing at runtime. Where possible I have included the functions for generating 59 | these at runtime either by loading from files or from raw binary data. 60 | 61 | To make it easier I have also included several functions for pregenerating Lisp code for icons, cursors and 62 | bitmaps. This has the equivalent semantics as the normal Win32 resource compiler but we're still doing 63 | all the work at runtime. 64 | 65 | The advantage of pregenerating code and putting that into your project is you don't need to ship 66 | external images which need to be loaded at runtime - you need only compile your code. 67 | 68 | To e.g. embed an icon into your project do the following: 69 | 1. Get your icon file e.g. by drawing it in gimp. make sure it is 32x32 pixels and exported as 32-bit 70 | with 8 bits each of alpha and rgb. 71 | 2. Run `(ftw:generate-icon-resource "myicon.ico")` 72 | This will print out the code you need to paste into your project. 73 | 74 | See the minesweeper example of how you can have a custom icon without shipping the file separately. 75 | 76 | ## 3.3 Dialogs 77 | The standard mechanism for drawing modal and modeless dialogs with Win32 is to use the 78 | resource compiler to generate the specification. This is not possible for us so we must do it at runtime. 79 | 80 | The functions `DIALOG-BOX` and `CREATE-DIALOG` create modal and modeless dialogs respectively. Both accept 81 | the same inputs. The difference is that modal dialogs do not return control to the caller until 82 | the dialog has been closed whereas modeless dialogs return control immediately and run alongside the original 83 | window. 84 | 85 | ## 3.4 Hwnd registry 86 | You may associate a window handle (hwnd) with a symbol name and optionally integer ID using `REGISTER-HWND`. 87 | Perform lookups by name or ID using `HWND-BY-NAME` and `HWND-BY-ID`: 88 | ``` 89 | ;; register an hwnd with the name FRED and ID 1 90 | (register-hwnd 'fred hwnd 1) 91 | ;; lookup hwnd with name FRED 92 | (hwnd-by-name 'fred) 93 | ;; lookup hwnd with ID 1 94 | (hwnd-by-id 1) 95 | ;; Lookup the name of the hwnd with ID 1 96 | (hwnd-name-by-id 1) 97 | ``` 98 | 99 | This makes it very simple to keep references to window handles in a consistent 100 | way rather than implementing private lists or globals in each program. 101 | 102 | # 4. Examples 103 | Various examples are provided which show various levels of abstractions and a 104 | good showcase of how to use it. 105 | 106 | ## 4.1 Zetcode samples 107 | The rather comprehensive tutorial for the C programming language can be 108 | found here [zetcode website](http://zetcode.com/gui/winapi/). 109 | These have been translated to Lisp and show that the same GUIs can be written 110 | which correspond to largely the same structure. 111 | 112 | ## 4.2 Climage 113 | This example GUI displays a two list boxes which show the packages and 114 | exported symbols. Clicking on a symbol displays the documentation for it. 115 | 116 | In addition, this GUI shows how to write and handle modal dialogs 117 | and accelerator keys -- these are the keyboard combinations which 118 | are used as shortcuts for menu items. 119 | Ctrl+F brings up a Find dialog to search for a given symbol. Ctrl+Q quits. 120 | 121 | ## 4.3 Dragdrop 122 | This shows how to support drag and drop functionality by handling the `WM_DROPFILES` message. 123 | 124 | ## 4.4 Pong 125 | This is a small and not very well written example of how you might go about 126 | writing games. It's just a silly little pong game but shows the basic idea. 127 | 128 | ## 4.5 Icon 129 | Shows how to add icons and other graphics. 130 | 131 | ## 4.6 Minesweeper 132 | Simple minesweeper game. 133 | 134 | ## 4.7 Tetris 135 | Simple tetris clone. 136 | 137 | ## 4.8 Macroman 138 | Simple pacman clone. Shows how to reduce flicker by double buffering. 139 | 140 | ## 4.9 Scrollbar 141 | How to add scrollbars and response to scoll messages. 142 | 143 | ## 4.10 Dragons: DNS client 144 | This implements a simple DNS client using the DNS client [dragons](http://github.com/fjames86/dragons). Enter the DNS address in the IP address field, select the 145 | record type and entry name and click Query. The list box below is filled with 146 | the results returned from the server, or a message box indicates an error status. 147 | 148 | ## 4.11 RPC: MsgWaitForMultipleObjects example 149 | This shows how to interleave networking and the message pump in the main thread, 150 | thereby making it possible to do asynchronous processing without blocking the 151 | gui. The example broadcasts to the rpcbind null procedure and fills in results 152 | as they are received. Requires [frpc2](http://github.com/fjames86/frpc2). 153 | This means the gui never blocks, the same technique can be applied to do any networking, 154 | e.g. background refreshes of data. The examples uses RPC over UDP but there is no reason 155 | why you couldn't also do non-blocking TCP networking as well. 156 | 157 | # 5. Notes 158 | Requires CFFI. Developed on Windows 8.1 and Windows 7 using SBCL 159 | but should work on basically any Windows version because all the APIs are 160 | pretty stable and haven't changed for a long time. 161 | Should work with any Lisp implementation which provides FFI callbacks 162 | 163 | ## 5.1 TODO 164 | - [ ] Try with CCL, Lispworks etc. 165 | - [ ] Better error handling. 166 | 167 | 168 | Licensed under the terms of the MIT license. 169 | 170 | Frank James 171 | October 2016. 172 | 173 | 174 | 175 | 176 | 177 | -------------------------------------------------------------------------------- /examples/climage/climage.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; This defines a simple gui which shows current state of the Lisp image 3 | ;;;; symbols, memory etc 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (ql:quickload "bordeaux-threads")) 7 | 8 | (defpackage #:ftw.climage 9 | (:use #:cl #:cffi #:ftw) 10 | (:export #:climage)) 11 | 12 | (in-package #:ftw.climage) 13 | 14 | 15 | ;; ------------- "Find" dialog --------------------- 16 | ;; This is a simple Find-type dialog which shows an 17 | ;; edit control (textbox), OK and Cancel buttons. 18 | ;; It returns the string the user wants to search for 19 | ;; or nil if they canceled. 20 | 21 | ;; Note: we could use the predefined modeless "find/replace" dialog that 22 | ;; MSFT provides for us. You can use it by calling ReplaceTextW. 23 | ;; But using it is a little involved so I just write my own. 24 | 25 | (defvar *show-find-dialog-text* nil) 26 | 27 | (defwndproc find-dialog-dlgproc (hwnd msg wparam lparam) 28 | (declare (ignore lparam)) 29 | (switch msg 30 | ((const +wm-initdialog+) 31 | 1) 32 | ((const +wm-command+) 33 | (switch (loword wparam) 34 | (1 ;; text box 35 | nil) 36 | (2 ;; ok 37 | (setf *show-find-dialog-text* (get-window-text (get-dialog-item hwnd 1))) 38 | (end-dialog hwnd)) 39 | (3 ;; cancel 40 | (setf *show-find-dialog-text* nil) 41 | (end-dialog hwnd))) 42 | 1) 43 | (t 44 | 0))) 45 | 46 | (defun show-find-dialog (&optional hwnd) 47 | (setf *show-find-dialog-text* nil) 48 | (dialog-box (callback find-dialog-dlgproc) 49 | `((:class-name :static 50 | :x 10 :y 10 :cx 40 :cy 10 51 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ss-left+) 52 | :title "Find what:") 53 | (:class-name :edit 54 | :id 1 55 | :x 55 :y 10 :cx 105 :cy 8 56 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ws-tabstop+)) 57 | (:class-name :button 58 | :id 2 59 | :title "OK" 60 | :x 55 :y 25 :cx 50 :cy 14 61 | :styles ,(logior-consts +ws-child+ +ws-visible+ +bs-defpushbutton+ +ws-tabstop+)) 62 | (:class-name :button 63 | :id 3 64 | :title "Cancel" 65 | :x 110 :y 25 :cx 50 :cy 14 66 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ws-tabstop+))) 67 | :hwnd (or hwnd (null-pointer)) 68 | :styles (logior-consts +ws-popup+ +ws-border+ +ws-sysmenu+ 69 | +ds-modalframe+ +ws-caption+ 70 | +ws-visible+ +ds-setfont+) 71 | :title "Find" 72 | :point-size 8 :font "Microsoft Sans Serif" 73 | :x 50 :y 50 :cx 170 :cy 45) 74 | *show-find-dialog-text*) 75 | 76 | 77 | ;; ------------- "About" type dialog --------------- 78 | 79 | ;; This defines a simple "about" type help dialog that 80 | ;; just shows normal info 81 | 82 | (defwndproc about-dlgproc (hwnd msg wparam lparam) 83 | (declare (ignore lparam)) 84 | (switch msg 85 | ((const +wm-initdialog+) 86 | 1) 87 | ((const +wm-command+) 88 | (switch (loword wparam) 89 | (1 ;; ok button 90 | (end-dialog hwnd))) 91 | 1) 92 | (t 93 | 0))) 94 | 95 | (defun about-dialog (&optional hwnd) 96 | (dialog-box (callback about-dlgproc) 97 | `((:class-name :static 98 | :title "This is a simple Win32 GUI written using Common Lisp bindings to the APIs 99 | available in User32.dll and Gdi32.dll. 100 | 101 | Copyright (c) Frank James 2016. 102 | " 103 | :x 25 :y 25 :cx 150 :cy 100 104 | :styles ,(logior-consts +ws-child+ +ws-visible+)) 105 | (:class-name :button 106 | :id 1 107 | :title "OK" 108 | :styles ,(logior-consts +ws-child+ +ws-visible+ 109 | +bs-defpushbutton+ +ws-tabstop+) 110 | :x 135 :y 75 :cx 50 :cy 15)) 111 | :hwnd hwnd 112 | :styles (logior-consts +ws-popup+ +ws-border+ +ws-sysmenu+ 113 | +ds-modalframe+ +ws-caption+ +ws-visible+ 114 | +ds-setfont+) 115 | :title "About Climage" 116 | :point-size 8 :font "Microsoft Sans Serif" 117 | :x 50 :y 50 :cx 200 :cy 100)) 118 | 119 | 120 | ;; ------------------------------------------------- 121 | 122 | 123 | 124 | (defparameter *windows* nil) 125 | 126 | (defclass window () 127 | ((hwnd :initarg :hwnd :initform nil :reader window-hwnd) 128 | (name :initarg :name :reader window-name) 129 | (id :initarg :id :initform 0 :reader window-id))) 130 | (defmethod print-object ((win window) stream) 131 | (print-unreadable-object (win stream :type t) 132 | (format stream ":NAME ~S :ID ~S :HWND ~X" 133 | (window-name win) 134 | (window-id win) 135 | (when (window-hwnd win) 136 | (pointer-address (window-hwnd win)))))) 137 | 138 | (defun add-window (win) 139 | (push win *windows*)) 140 | (defun window-by-hwnd (hwnd) 141 | (find hwnd *windows* :key #'window-hwnd :test #'pointer-eq)) 142 | (defun window-by-name (name) 143 | (find name *windows* :key #'window-name :test #'eq)) 144 | (defun window-by-id (id) 145 | (find id *windows* :key #'window-id :test #'=)) 146 | 147 | (defvar *pkg-list* nil) 148 | (defvar *sym-list* nil) 149 | (defun get-sym-list (pkg) 150 | (let ((syms nil)) 151 | (do-external-symbols (sym pkg) 152 | (pushnew sym syms)) 153 | syms)) 154 | (defun change-to-package (hwnd pkg) 155 | (let ((p (find-package pkg))) 156 | (cond 157 | (p 158 | (let ((win (window-by-name 'pkg-listbox)) 159 | (index (position (package-name p) *pkg-list* :test #'string-equal))) 160 | (cond 161 | (index 162 | (send-message (window-hwnd win) 163 | (const +lb-setcursel+) 164 | index 165 | 0) 166 | (send-message hwnd (const +wm-command+) 167 | (make-lparam (window-id win) (const +lbn-selchange+)) 168 | 0) 169 | t) 170 | (t 171 | (message-box :hwnd hwnd 172 | :text (format nil "Package ~S not found" pkg) 173 | :caption "Error" 174 | :icon :error) 175 | nil)))) 176 | (t 177 | (message-box :hwnd hwnd 178 | :text (format nil "Package ~S not found" pkg) 179 | :caption "Error" 180 | :icon :error))))) 181 | 182 | 183 | (defun change-to-sym (hwnd sym) 184 | (let ((win (window-by-name 'sym-listbox)) 185 | (index (position sym *sym-list* :test #'string-equal))) 186 | (cond 187 | (index 188 | (send-message (window-hwnd win) 189 | (const +lb-setcursel+) 190 | index 191 | 0) 192 | (send-message hwnd (const +wm-command+) 193 | (make-lparam (window-id win) (const +lbn-selchange+)) 194 | 0) 195 | t) 196 | (t 197 | (message-box :hwnd hwnd 198 | :text (format nil "Symbol ~S not found" sym) 199 | :caption "Error" 200 | :icon :error) 201 | nil)))) 202 | 203 | (defun add-menu-bar% (hwnd menus) 204 | (labels ((process-menu (parent menu) 205 | (destructuring-bind (type sym flags &key name id children) menu 206 | (ecase type 207 | (:menu 208 | (let ((m (create-menu))) 209 | (dolist (child children) 210 | (process-menu m child)) 211 | (append-menu parent flags m name))) 212 | (:item 213 | (append-menu parent flags (or id 0) name) 214 | (add-window (make-instance 'window :name sym :id (or id 0)))))))) 215 | 216 | (let ((bar (create-menu))) 217 | (dolist (menu menus) 218 | (process-menu bar menu)) 219 | 220 | (set-menu hwnd bar)))) 221 | 222 | (defparameter *id-counter* 0) 223 | (defun genid () 224 | (incf *id-counter*) 225 | *id-counter*) 226 | 227 | (defvar *accel* nil) 228 | 229 | (defun climage-create (hwnd cs) 230 | "On creation we do: 231 | * add menu 232 | * add static windows for labels etc 233 | * add listbox for packages 234 | * add listbox for symbols 235 | " 236 | (declare (ignore cs)) 237 | 238 | (setf *windows* nil) 239 | 240 | (add-menu-bar% hwnd `((:menu file-menu (:popup) :name "&File" 241 | :children 242 | ((:item find-menu-item (:string) 243 | :name ,(format nil "&Find~ACtrl+F" #\tab) 244 | :id ,(genid)) 245 | (:item separator1 (:separator)) 246 | (:item quit-menu-item (:string) 247 | :name ,(format nil "&Quit~ACtrl+Q" #\tab) 248 | :id ,(genid)))) 249 | (:menu image-menu (:popup) :name "&Image" 250 | :children 251 | ((:item room-menu-item (:string) 252 | :name "&Room" 253 | :id ,(genid)) 254 | (:item separator2 (:separator)) 255 | (:item threads-menu-item (:string) 256 | :name "&Threads" :id ,(genid)))) 257 | (:menu help-menu (:popup) :name "&Help" 258 | :children 259 | ((:item about-menu-item (:string) 260 | :name "&About" 261 | :id ,(genid)))))) 262 | 263 | 264 | ;; create accelerator table for the find menu item 265 | (setf *accel* 266 | (create-accelerator-table 267 | `((:keyf ,(window-id (window-by-name 'find-menu-item)) :control :virtual-key) 268 | (:keyq ,(window-id (window-by-name 'quit-menu-item)) :control :virtual-key)))) 269 | 270 | ;; add all the controls 271 | (let ((h (create-window :static 272 | :window-name "Packages" 273 | :styles (logior-consts +ws-visible+ +ws-child+) 274 | :x 25 :y 25 :width 200 :height 20 275 | :parent hwnd))) 276 | (add-window (make-instance 'window :name 'pkg-label :hwnd h)) 277 | (set-default-font h)) 278 | 279 | (let* ((id (genid)) 280 | (h 281 | (create-window :listbox 282 | :styles (logior-consts +ws-child+ +ws-visible+ +lbs-notify+ +ws-vscroll+ 283 | +ws-tabstop+) 284 | :x 25 :y 50 :width 200 :height 350 285 | :parent hwnd 286 | :menu id))) 287 | (add-window (make-instance 'window :name 'pkg-listbox :hwnd h :id id)) 288 | (set-default-font h) 289 | 290 | (setf *pkg-list* (mapcar #'package-name (list-all-packages))) 291 | (dolist (pkg *pkg-list*) 292 | (with-wide-string (s pkg) 293 | (send-message h (const +lb-addstring+) 0 s)))) 294 | 295 | ;; symbol listbox 296 | (let ((h (create-window :static 297 | :window-name "Symbols" 298 | :styles (logior-consts +ws-visible+ +ws-child+) 299 | :x 250 :y 25 :width 300 :height 20 300 | :parent hwnd))) 301 | (add-window (make-instance 'window :name 'sym-label :hwnd h)) 302 | (set-default-font h)) 303 | 304 | (let* ((id (genid)) 305 | (h 306 | (create-window :listbox 307 | :styles (logior-consts +ws-child+ +ws-visible+ +lbs-notify+ +ws-vscroll+ +ws-tabstop+) 308 | :x 250 :y 50 :width 300 :height 350 309 | :parent hwnd 310 | :menu id))) 311 | (add-window (make-instance 'window :name 'sym-listbox :hwnd h :id id)) 312 | (set-default-font h) 313 | 314 | (setf *sym-list* (get-sym-list (first *pkg-list*))) 315 | (dolist (sym *sym-list*) 316 | (with-wide-string (s (symbol-name sym)) 317 | (send-message h (const +lb-addstring+) 0 s)))) 318 | 319 | (let ((h 320 | (create-window :static 321 | :window-name "" 322 | :styles (logior-consts +ws-child+ +ws-visible+) 323 | :x 575 :y 50 :width 400 :height 350 324 | :parent hwnd))) 325 | (add-window (make-instance 'window :name 'sym-static :hwnd h)) 326 | (set-default-font h))) 327 | 328 | (defun climage-command (hwnd wparam lparam) 329 | (declare (ignore lparam)) 330 | (let ((window (window-by-id (loword wparam)))) 331 | (when window 332 | (case (window-name window) 333 | (quit-menu-item 334 | (send-message hwnd (const +wm-close+) 0 0)) 335 | (pkg-listbox 336 | (when (= (hiword wparam) (const +lbn-selchange+)) 337 | (let ((sel (send-message (window-hwnd window) (const +lb-getcursel+) 0 0)) 338 | (sym-listbox (window-by-name 'sym-listbox))) 339 | ;; clear listbox and insert all symbols 340 | (send-message (window-hwnd sym-listbox) (const +lb-resetcontent+) 0 0) 341 | 342 | (setf *sym-list* (get-sym-list (nth sel *pkg-list*))) 343 | (dolist (sym *sym-list*) 344 | (with-wide-string (s (symbol-name sym)) 345 | (send-message (window-hwnd sym-listbox) (const +lb-addstring+) 0 s))) 346 | (invalidate-rect (window-hwnd sym-listbox) nil t)))) 347 | (sym-listbox 348 | (when (= (hiword wparam) (const +lbn-selchange+)) 349 | (let ((sel (send-message (window-hwnd window) (const +lb-getcursel+) 0 0))) 350 | ;; print info about the symbol 351 | (set-window-text (window-hwnd (window-by-name 'sym-static)) 352 | (with-output-to-string (s) 353 | (describe (nth sel *sym-list*) s)))))) 354 | (find-menu-item 355 | (let ((find-text (show-find-dialog hwnd))) 356 | (when find-text 357 | ;; change to package, if colon is in the name 358 | (let ((index (position #\: find-text :test #'char=))) 359 | (when index 360 | (when (change-to-package hwnd (string-upcase (subseq find-text 0 index))) 361 | (setf find-text (subseq find-text (1+ index))) 362 | ;; lookup the symbol name 363 | (change-to-sym hwnd (string-upcase find-text)))))))) 364 | (room-menu-item 365 | (let ((rstring (with-output-to-string (*standard-output*) (room)))) 366 | (message-box :hwnd hwnd 367 | :text rstring 368 | :caption "Room" 369 | :icon :information))) 370 | (threads-menu-item 371 | (let ((tstring (with-output-to-string (s) 372 | (dolist (th (bt:all-threads)) 373 | (format s "~S~%" th))))) 374 | (message-box :hwnd hwnd 375 | :text tstring 376 | :caption "Threads" 377 | :icon :information))) 378 | (about-menu-item 379 | (about-dialog hwnd)))))) 380 | 381 | (defun climage-size (hwnd wparam lparam) 382 | (declare (ignore wparam hwnd)) 383 | (let ((width (loword lparam)) 384 | (height (hiword lparam))) 385 | 386 | (let ((pkg-listbox (window-by-name 'pkg-listbox))) 387 | (when pkg-listbox 388 | (set-window-pos (window-hwnd pkg-listbox) :top 25 50 200 (- height 100)))) 389 | 390 | (let ((sym-listbox (window-by-name 'sym-listbox))) 391 | (when sym-listbox 392 | (set-window-pos (window-hwnd sym-listbox) :top 250 50 300 (- height 100)))) 393 | 394 | (let ((sym-static (window-by-name 'sym-static))) 395 | (when sym-static 396 | (set-window-pos (window-hwnd sym-static) :top 575 50 (- width 600) (- height 100)) 397 | (invalidate-rect (window-hwnd sym-static) nil t))))) 398 | 399 | 400 | (defwndproc climage-wndproc (hwnd msg wparam lparam) 401 | ;; (format t "MSG: ~S WPARAM ~S LPARAM ~S~%" msg wparam lparam) 402 | (switch msg 403 | ((const +wm-create+) 404 | (climage-create hwnd (foreign-createstruct (make-pointer lparam)))) 405 | ((const +wm-command+) 406 | (climage-command hwnd wparam lparam)) 407 | ((const +wm-size+) 408 | (climage-size hwnd wparam lparam)) 409 | ((const +wm-destroy+) 410 | (destroy-accelerator-table *accel*) 411 | (setf *accel* nil) 412 | (post-quit-message))) 413 | (default-window-proc hwnd msg wparam lparam)) 414 | 415 | 416 | (defun climage (&key background-thread-p) 417 | "Run the CLIMAGE GUI. 418 | BACKGROUND-THREAD-P ::= if this is true then the GUI is run from a background thread." 419 | (when background-thread-p 420 | (bt:make-thread #'climage :name "CLIMAGE") 421 | (return-from climage nil)) 422 | 423 | (register-class "CLIMAGE" 424 | (callback climage-wndproc) 425 | :background (get-sys-color-brush :3d-face) 426 | :icon (load-icon :application) 427 | :cursor (load-cursor :arrow)) 428 | (let ((hwnd (create-window "CLIMAGE" 429 | :window-name "Common Lisp Image" 430 | :styles '(:overlapped-window :visible) 431 | :x 100 :y 100 :width 800 :height 400)) 432 | (msg (make-msg))) 433 | (unwind-protect 434 | (progn 435 | (show-window hwnd) 436 | (update-window hwnd) 437 | (set-foreground-window hwnd) 438 | (do ((done nil)) 439 | (done) 440 | (let ((r (get-message msg))) 441 | (cond 442 | ((= r 0) (setf done t)) 443 | ((zerop (translate-accelerator hwnd *accel* msg)) 444 | (translate-message msg) 445 | (dispatch-message msg)))))) 446 | (unregister-class "CLIMAGE")))) 447 | 448 | 449 | 450 | 451 | -------------------------------------------------------------------------------- /examples/console/console.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2018 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; This shows how to use the console API. This gives us something 5 | ;;; similar to curses for the windows console. The example below 6 | ;;; just draws two regions with a function key bar at the bottom. 7 | ;;; The left hand panel shows some example text (lorem ipsum), I 8 | ;;; never got round to making the right hand side do anything. 9 | 10 | 11 | (defpackage #:ftw.console 12 | (:use #:cl #:ftw) 13 | (:export #:console)) 14 | 15 | (in-package #:ftw.console) 16 | 17 | (defconstant +width+ 100) 18 | (defconstant +height+ 30) 19 | 20 | (defvar *init* nil) 21 | (defun init-console () 22 | (unless *init* 23 | (show-window (get-console-window) :show) 24 | (show-window (get-console-window) :show) 25 | (show-window (get-console-window) :maximize) 26 | (set-std-handle (open-console-std-input) :input) 27 | (set-std-handle (create-console-screen-buffer) :output) 28 | (set-console-active-screen-buffer (get-std-handle :output)) 29 | (setf *init* t))) 30 | 31 | (defun justify-text (text width &optional (justify :left)) 32 | (let ((lines nil)) 33 | (do ((i 0 (1+ i)) 34 | (col 0 (1+ col)) 35 | (line-start 0) 36 | (line-break 0)) 37 | ((= i (length text)) 38 | (push (concatenate 'string 39 | (subseq text line-start) 40 | (loop :for i :below (- width col) :collect #\space)) 41 | lines)) 42 | (when (or (= i (1- (length text))) 43 | (char= (char text i) #\space) 44 | (char= (char text i) #\return) 45 | (char= (char text i) #\newline)) 46 | (setf line-break i)) 47 | 48 | (when (= col width) 49 | (push (ecase justify 50 | (:left 51 | (concatenate 'string 52 | (subseq text line-start line-break) 53 | (loop :for j :below (- width (- line-break line-start)) :collect #\space))) 54 | (:right 55 | (concatenate 'string 56 | (loop :for j :below (- width (- line-break line-start)) :collect #\space) 57 | (subseq text line-start line-break))) 58 | ((:center :centre) 59 | (concatenate 'string 60 | (loop :for j :below (truncate (- width (- line-break line-start)) 2) :collect #\space) 61 | (subseq text line-start line-break) 62 | (loop :for j :below (truncate (- width (- line-break line-start)) 2) :collect #\space)))) 63 | lines) 64 | (setf i line-break 65 | col 0 66 | line-start line-break 67 | line-break i))) 68 | (nreverse lines))) 69 | 70 | 71 | 72 | (defparameter *lorem-ipsum* 73 | "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") 74 | 75 | (defun write-left-panel (output string) 76 | (write-console-string output 77 | (justify-text string (truncate +width+ 3)) 78 | :x 2 :y 2 79 | :attrs (char-info-attrs :fg-r :bg-r :bg-g :bg-b))) 80 | 81 | 82 | (defun console () 83 | (init-console) 84 | (set-console-title "Lisp Console Program") 85 | (show-window (get-console-window) :show) 86 | 87 | (let ((in (get-std-handle :in)) 88 | (out (get-std-handle :out))) 89 | (set-console-mode in (logior ftw::+enable-processed-input+ 90 | ftw::+enable-insert-mode+)) 91 | 92 | (set-console-cursor-position in 0 0) 93 | (set-console-cursor-info out :visible nil) 94 | 95 | (set-console-screen-buffer-info out 96 | :size (list +width+ +height+) 97 | :max-size (list +width+ +height+) 98 | :fullscreen-p t) 99 | (show-window (get-console-window) :maximize) 100 | 101 | (fill-console-output-character out #\space 0 0 (* +width+ +height+)) 102 | (fill-console-output-attribute out 103 | (char-info-attrs :bg-b :bg-r :bg-g) 104 | 0 0 (* (1- +height+) +width+)) 105 | 106 | (fill-console-output-attribute out 107 | (char-info-attrs :bg-b) 108 | 0 (1- +height+) +width+) 109 | 110 | (write-console-output out 111 | (list (string-info "Package" 112 | (char-info-attrs :fg-r :bg-r :bg-g :bg-b))) 113 | :x 20 :y 1) 114 | 115 | (write-left-panel out *lorem-ipsum*) 116 | 117 | 118 | (do ((row 2 (1+ row))) 119 | ((= row (- +height+ 2))) 120 | (fill-console-output-attribute out 121 | (char-info-attrs :bg-b :bg-g) 122 | 2 row 123 | (- (truncate +width+ 2) 5))) 124 | 125 | (write-console-output out 126 | (list (string-info "Symbol" 127 | (char-info-attrs :fg-r :bg-r :bg-g :bg-b))) 128 | :x 70 :y 1) 129 | 130 | (do ((row 2 (1+ row))) 131 | ((= row (- +height+ 2))) 132 | (fill-console-output-attribute out 133 | (char-info-attrs :bg-b :bg-g) 134 | 53 row (- (truncate +width+ 2) 5))) 135 | 136 | 137 | 138 | 139 | (mapc (lambda (name x) 140 | (write-console-output out 141 | (list (string-info name 142 | (char-info-attrs :fg-b :fg-g :fg-r :fg-intensity :bg-b))) 143 | :x x :y (1- +height+))) 144 | '("Search F1" "Exit F2") 145 | '(5 25)) 146 | 147 | (do ((done nil)) 148 | (done) 149 | (let ((events (read-console-input in))) 150 | (dolist (event events) 151 | (case (car event) 152 | (ftw::key 153 | (let ((vkey (getf (cdr event) 'ftw::keycode)) 154 | (keydown (getf (cdr event) 'ftw::keydown))) 155 | (unless keydown 156 | (switch vkey 157 | (ftw::+vk-f1+ (write-left-panel out "F1 ")) 158 | (ftw::+vk-f2+ (setf done t))))))))))) 159 | 160 | (show-window (get-console-window) :hide)) 161 | 162 | 163 | 164 | 165 | -------------------------------------------------------------------------------- /examples/dialogs/dialogs.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | (defpackage #:ftw.dialogs 5 | (:use #:cl #:cffi #:ftw)) 6 | 7 | (in-package #:ftw.dialogs) 8 | 9 | ;; ----------- FindReplace --------------- 10 | 11 | ;; The FindReplace dialogs FindText and ReplaceText are 12 | ;; modeless and therefore require a little bit more work than 13 | ;; the modal dialogs. This is because they require us allocating 14 | ;; buffers which live for the lifetime of the dialog. In addition 15 | ;; we must call IsDialogMessage() and intercept the FINDMSGSTRING 16 | ;; message which tells us the user clicked on the "find next" button 17 | ;; in the dialog. 18 | 19 | 20 | (defvar *fr* nil) 21 | 22 | (defwndproc findtext-wndproc (hwnd msg wparam lparam) 23 | (switch msg 24 | ((const +wm-create+) 25 | (setf *fr* (find-text :hwnd hwnd))) 26 | ((get-findmsgstring) 27 | (multiple-value-bind (flags find replace) (foreign-findreplace (make-pointer lparam)) 28 | (format t "find replace ~S ~S ~S~%" flags find replace) 29 | (when (member :dialog-term flags) 30 | (free-findreplace *fr*) 31 | (setf *fr* nil)))) 32 | ((const +wm-destroy+) 33 | (post-quit-message))) 34 | (default-window-proc hwnd msg wparam lparam)) 35 | 36 | 37 | (defun findtext-test () 38 | (let ((cname "FTW_FINDTEXT")) 39 | (register-class cname 40 | (callback findtext-wndproc) 41 | :cursor (load-cursor :arrow) 42 | :background (get-sys-color-brush :3d-face)) 43 | (let ((hwnd (create-window cname 44 | :window-name "Find text" 45 | :styles (logior-consts +ws-overlappedwindow+ +ws-visible+) 46 | :x 100 :y 100 :width 400 :height 300)) 47 | (msg (make-msg))) 48 | (unless hwnd (return-from findtext-test nil)) 49 | 50 | (show-window hwnd) 51 | (update-window hwnd) 52 | (set-foreground-window hwnd) 53 | (do ((done nil)) 54 | (done) 55 | (let ((r (get-message msg))) 56 | (cond 57 | ((zerop r) (setf done t)) 58 | ;; Note: we need to call is-dialog-message in the mesasge loop as per MSDN instructions 59 | ((not (is-dialog-message hwnd msg)) 60 | (translate-message msg) 61 | (dispatch-message msg)))))))) 62 | 63 | ;; --------------------- ChooseColor ------------------- 64 | 65 | (defun choose-color-test () 66 | (choose-color)) 67 | 68 | ;; ------------------- Choose Font ------------ 69 | 70 | (defun choose-font-test () 71 | (choose-font)) 72 | 73 | ;; -------------------- Open file ----------- 74 | 75 | (defun open-file-test () 76 | (get-open-file-name)) 77 | 78 | ;; -------------------- Save file ------------- 79 | 80 | (defun save-file-test () 81 | (get-save-file-name)) 82 | 83 | ;; --------------- Print -------------- 84 | 85 | (defwndproc print-wndproc (hwnd msg wparam lparam) 86 | (switch msg 87 | (ftw::+wm-keydown+ 88 | (let ((pinfo (print-dialog hwnd 89 | :min-page 1 90 | :max-page 100 91 | :page-ranges '((1 3) (2 4)) 92 | :flags (logior ftw::+pd-returndc+)))) 93 | (message-box :hwnd hwnd 94 | :text (format nil "~S~%" pinfo) 95 | :caption "Print dialog"))) 96 | (ftw::+wm-destroy+ 97 | (post-quit-message))) 98 | (default-window-proc hwnd msg wparam lparam)) 99 | 100 | (defun print-test () 101 | (default-message-loop 'print-wndproc)) 102 | 103 | ;; ------------------ Page setup ---------- 104 | 105 | (defun page-setup-test () 106 | (page-setup-dialog)) 107 | 108 | 109 | ;; ------------- Example ------------ 110 | 111 | (defvar *show-find-dialog-text* nil) 112 | 113 | (defwndproc find-dialog-dlgproc (hwnd msg wparam lparam) 114 | (declare (ignore lparam)) 115 | (switch msg 116 | ((const +wm-initdialog+) 117 | 1) 118 | ((const +wm-command+) 119 | (switch (loword wparam) 120 | (1 ;; text box 121 | nil) 122 | (2 ;; ok 123 | (setf *show-find-dialog-text* (get-window-text (get-dialog-item hwnd 1))) 124 | (end-dialog hwnd)) 125 | (3 ;; cancel 126 | (setf *show-find-dialog-text* nil) 127 | (end-dialog hwnd))) 128 | 1) 129 | (t 130 | 0))) 131 | 132 | (defun show-find-dialog (&optional hwnd) 133 | (setf *show-find-dialog-text* nil) 134 | (dialog-box (callback find-dialog-dlgproc) 135 | `((:class-name :static 136 | :x 10 :y 10 :cx 40 :cy 10 137 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ss-left+) 138 | :title "Find what:") 139 | (:class-name :edit 140 | :id 1 141 | :x 55 :y 10 :cx 105 :cy 8 142 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ws-tabstop+)) 143 | (:class-name :button 144 | :id 2 145 | :title "OK" 146 | :x 55 :y 25 :cx 50 :cy 14 147 | :styles ,(logior-consts +ws-child+ +ws-visible+ +bs-defpushbutton+ +ws-tabstop+)) 148 | (:class-name :button 149 | :id 3 150 | :title "Cancel" 151 | :x 110 :y 25 :cx 50 :cy 14 152 | :styles ,(logior-consts +ws-child+ +ws-visible+ +ws-tabstop+))) 153 | :hwnd (or hwnd (null-pointer)) 154 | :styles (logior-consts +ws-popup+ +ws-border+ +ws-sysmenu+ 155 | +ds-modalframe+ +ws-caption+ 156 | +ws-visible+ +ds-setfont+) 157 | :title "Find" 158 | :point-size 8 :font "Microsoft Sans Serif" 159 | :x 50 :y 50 :cx 170 :cy 45) 160 | *show-find-dialog-text*) 161 | -------------------------------------------------------------------------------- /examples/dragdrop/dragdrop.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | 5 | (defpackage #:ftw.dragdrop 6 | (:use #:cl #:cffi #:ftw) 7 | (:export #:dragdrop)) 8 | 9 | (in-package #:ftw.dragdrop) 10 | 11 | ;;; We define an empty gui and wait for wm_dropfiles message. 12 | ;;; When we receive it we issue a messagebox to display them 13 | 14 | (defwndproc dragdrop-wndproc (hwnd msg wparam lparam) 15 | (switch msg 16 | ((const +wm-create+) 17 | (drag-accept-files hwnd t)) 18 | ((const +wm-dropfiles+) 19 | (let ((hdrop (make-pointer wparam))) 20 | (message-box :hwnd hwnd 21 | :text (format nil "Files:~%~{~A~%~}~%" (drag-query-files hdrop)) 22 | :caption "Dragged files?"))) 23 | ((const +wm-destroy+) 24 | (drag-accept-files hwnd nil) 25 | (post-quit-message))) 26 | (default-window-proc hwnd msg wparam lparam)) 27 | 28 | 29 | (defun dragdrop () 30 | (default-message-loop (callback dragdrop-wndproc) 31 | :class-name "FTW_DRAGDROP" 32 | :title "Drag and drop" 33 | :width 500 :height 400)) 34 | 35 | ;; ----------- TODO ----------------------- 36 | 37 | (defcfun (%open-clipboard "OpenClipboard" :convention :stdcall) 38 | :boolean 39 | (hwnd :pointer)) 40 | 41 | (defun open-clipboard (&optional hwnd) 42 | (%open-clipboard (or hwnd (null-pointer)))) 43 | 44 | (defcfun (%close-clipboard "CloseClipboard" :convention :stdcall) 45 | :boolean) 46 | 47 | (defun close-clipboard () 48 | (%close-clipboard)) 49 | 50 | (defcfun (%get-clipboard-data "GetClipboardData" :convention :stdcall) 51 | :pointer 52 | (format :uint32)) 53 | 54 | (defun get-clipboard-data (format) 55 | (%get-clipboard-data format)) 56 | 57 | (defcfun (%empty-clipboard "EmptyClipboard" :convention :stdcall) 58 | :boolean) 59 | 60 | (defun empty-clipboard () 61 | (%empty-clipboard)) 62 | 63 | (defcfun (%set-clipboard-data "SetClipboardData" :convention :stdcall) 64 | :boolean 65 | (format :uint32) 66 | (mem :pointer)) 67 | 68 | (defun set-clipboard-format (format mem) 69 | (%set-clipboard-data format mem)) 70 | 71 | -------------------------------------------------------------------------------- /examples/dragons/dragons.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; DNS client. Provides lookups for various record types. 5 | 6 | (defpackage #:ftw.dragons 7 | (:use #:cl #:ftw) 8 | (:export #:dragons)) 9 | 10 | (in-package #:ftw.dragons) 11 | 12 | (defparameter *recordtypes* 13 | '(("A" :a) 14 | ("NS" :ns) 15 | ("CNAME" :cname) 16 | ("SOA" :soa) 17 | ("MB" :mb) 18 | ("MR" :mr) 19 | ("NULL" :null) 20 | ("WKS" :wks) 21 | ("PTR" :ptr) 22 | ("HINFO" :hinfo) 23 | ("MINFO" :minfo) 24 | ("MX" :mx) 25 | ("TXT" :txt) 26 | ("AAAA" :aaaa) 27 | ("SRV" :srv) 28 | ("AXFR" :axfr) 29 | ("MAILB" :mailb) 30 | ("MAILA" :maila) 31 | ("ALL" :all))) 32 | 33 | (defun dragons-create (hwnd) 34 | (create-static "DNS Address:" :parent hwnd :styles (logior ftw::+ws-visible+ ftw::+ws-child+) :x 25 :y 27 :width 100 :height 25) 35 | 36 | (let ((default-font (get-default-font))) 37 | (let ((h (create-window ftw::+wc-ipaddress+ 38 | :parent hwnd 39 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+) 40 | :x 140 :y 25 :width 200 :height 25))) 41 | (set-default-font h default-font) 42 | 43 | (let ((ips dns:*dns-addrs*)) 44 | (when ips 45 | (let ((inaddr (fsocket:sockaddr-in-addr (first ips)))) 46 | (send-message h 47 | ftw::+ipm-setaddress+ 48 | 0 49 | (logior (ash (aref inaddr 0) 24) 50 | (ash (aref inaddr 1) 16) 51 | (ash (aref inaddr 2) 8) 52 | (aref inaddr 3)))))) 53 | (register-hwnd 'ipaddress h)) 54 | 55 | (let ((h (create-window :button 56 | :window-name "Search" 57 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ 58 | ftw::+bs-groupbox+) 59 | :x 15 :y 65 :width 335 :height 130 60 | :parent hwnd))) 61 | (set-default-font h default-font)) 62 | 63 | (create-static "Record Type:" :parent hwnd :x 25 :y 97 :width 100 :height 25) 64 | (create-static "Name:" :parent hwnd :x 25 :y 127 :width 100 :height 25) 65 | 66 | (let ((h (create-window :combobox :window-name "Fred" :parent hwnd 67 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ ftw::+cbs-dropdownlist+ ftw::+ws-vscroll+) 68 | :x 140 :y 95 :width 200 :height 200 69 | :menu 2))) 70 | (set-default-font h default-font) 71 | (dolist (str (mapcar #'car *recordtypes*)) 72 | (with-wide-string (s str) 73 | (send-message h ftw::+cb-addstring+ 0 s))) 74 | (send-message h ftw::+cb-setcursel+ 0 0) 75 | (register-hwnd 'recordtype h 2)) 76 | 77 | (let ((h (create-edit :parent hwnd 78 | :x 140 :y 125 :width 200 :height 25))) 79 | (register-hwnd 'name h)) 80 | 81 | (let ((h (create-window :button 82 | :window-name "Query" 83 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ 84 | ftw::+bs-defpushbutton+) 85 | :x 265 :y 160 :width 75 :height 23 86 | :parent hwnd 87 | :menu 1))) 88 | (set-default-font h default-font) 89 | (register-hwnd 'query h 1)) 90 | 91 | (let ((h (create-window :listbox 92 | :x 15 :y 215 :width 335 :height 200 93 | :parent hwnd 94 | :ex-styles ftw::+ws-ex-clientedge+ 95 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ 96 | ftw::+ws-hscroll+ ftw::+ws-vscroll+)))) 97 | (set-default-font h default-font) 98 | (register-hwnd 'rlist h)))) 99 | 100 | (defun get-record-type () 101 | (let ((hwnd (hwnd-by-name 'recordtype))) 102 | (let ((idx (send-message hwnd ftw::+cb-getcursel+ 0 0))) 103 | (when (>= idx 0) 104 | (second (nth idx *recordtypes*)))))) 105 | 106 | (defun get-dns-addr () 107 | (let ((hwnd (hwnd-by-name 'ipaddress))) 108 | (cffi:with-foreign-object (inaddr :uint32) 109 | (send-message hwnd ftw::+ipm-getaddress+ 0 inaddr) 110 | (fsocket:sockaddr-in (cffi:mem-ref inaddr :uint32) 53)))) 111 | 112 | (defun format-rr (rr) 113 | (case (dragons:rr-type rr) 114 | (:a 115 | (let ((inaddr (dragons:rr-rdata rr))) 116 | (format nil "~A.~A.~A.~A" 117 | (aref inaddr 0) (aref inaddr 1) (aref inaddr 2) (aref inaddr 3)))) 118 | (otherwise 119 | (let ((*print-pretty* nil)) 120 | (format nil "~S" (dragons:rr-rdata rr)))))) 121 | 122 | (defun format-results (results) 123 | (let ((h (hwnd-by-name 'rlist))) 124 | (send-message h ftw::+lb-resetcontent+ 0 0) 125 | (dolist (rr results) 126 | (ftw:with-wide-string (ws (format-rr rr)) 127 | (send-message h ftw::+lb-addstring+ 0 ws))))) 128 | 129 | (defun dragons-command (hwnd id) 130 | (switch id 131 | (1 ;; query button 132 | (handler-case 133 | (let ((answers (dns:query (dns:question (get-window-text (hwnd-by-name 'name)) 134 | (get-record-type)) 135 | :addr (get-dns-addr) 136 | :timeout 500))) 137 | (format-results answers)) 138 | (error (e) 139 | (message-box :hwnd hwnd 140 | :text (format nil "~A" e) 141 | :caption "Error" 142 | :icon :error)))))) 143 | 144 | ;; (defmacro defwndclass (name-and-options (hwnd msg wparam lparam) &body body) 145 | ;; (let* ((name (if (listp name-and-options) (car name-and-options) name-and-options)) 146 | ;; (options (when (listp name-and-options) (cdr name-and-options))) 147 | ;; (procname (intern (format nil "%~A-WNDPROC" name)))) 148 | ;; (destructuring-bind (&key icon icon-small cursor background) options 149 | ;; `(progn 150 | ;; (defwndproc ,procname (,hwnd ,msg ,wparam ,lparam) ,@body) 151 | ;; (register-class ,(format nil "~A_~A" 152 | ;; (package-name (symbol-package name)) 153 | ;; (symbol-name name)) 154 | ;; (cffi:callback ,procname) 155 | ;; :icon ,icon 156 | ;; :icon-small ,icon-small 157 | ;; :cursor ,(or cursor `(load-cursor :arrow)) 158 | ;; :background ,(or background `(get-sys-color-brush :3d-face))))))) 159 | 160 | ;; (defwndclass dragonsmain (hwnd msg wparam lparam) 161 | ;; (switch msg 162 | ;; (ftw::+wm-create+ 163 | ;; (dragons-create hwnd)) 164 | ;; (ftw::+wm-command+ 165 | ;; (dragons-command hwnd (loword wparam))) 166 | ;; (ftw::+wm-destroy+ 167 | ;; (post-quit-message))) 168 | ;; (default-window-proc hwnd msg wparam lparam)) 169 | 170 | (defun dragons-size (hwnd w h) 171 | (declare (ignore hwnd)) 172 | (set-window-pos (hwnd-by-name 'rlist) :top 173 | 0 0 174 | (- w 30) (- h 220) 175 | '(:no-move))) 176 | 177 | (defwndproc dragons-wndproc (hwnd msg wparam lparam) 178 | (switch msg 179 | (ftw::+wm-create+ 180 | (dragons-create hwnd)) 181 | (ftw::+wm-command+ 182 | (dragons-command hwnd (loword wparam))) 183 | (ftw::+wm-destroy+ 184 | (post-quit-message)) 185 | (ftw::+wm-size+ 186 | (dragons-size hwnd (loword lparam) (hiword lparam)))) 187 | (default-window-proc hwnd msg wparam lparam)) 188 | 189 | (defun dragons () 190 | (default-message-loop 'dragons-wndproc 191 | :class-name "FTW_DRAGONS_MAIN" 192 | :title "Dragons DNS Viewer" 193 | :width 370 :height 440)) 194 | 195 | ;; :styles (logior ftw::+ws-overlapped+ ftw::+ws-caption+ ftw::+ws-sysmenu+ 196 | ;; ftw::+ws-minimizebox+ 197 | ;; ftw::+ws-visible+))) 198 | -------------------------------------------------------------------------------- /examples/macroman/macroman.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; This is a simple pac-man type game. 5 | ;;; It's a naive implementation - the following are left as an 6 | ;;; excersise for the reader: 7 | ;;; 1. Use bitmaps instead of geometric shapes for the characters especially the ghosts 8 | ;;; - alternative is to work out how to draw the ghosts using poly-polybezier 9 | ;;; 2. Write an actual AI for the ghosts. At the moment they go in a stright line until 10 | ;;; they hit a wall then choose randomly. 11 | ;;; 3. Add different levels 12 | ;;; 4. Add the fruit 13 | ;;; 5. Animations between levels 14 | ;;; 6. High score save file. 15 | ;;; 7. Basically all state is held by lots of globals. This could be consolidated into 16 | ;;; a struct which holds all the state. 17 | ;;; 18 | ;;; See here for more info 19 | ;;; http://www.gamasutra.com/view/feature/3938/the_pacman_dossier.php?print=1 20 | ;;; 21 | 22 | 23 | 24 | (defpackage #:ftw.macroman 25 | (:use #:cl #:ftw) 26 | (:export #:macroman)) 27 | 28 | (in-package #:ftw.macroman) 29 | 30 | ;; map is 26 wide and 29 high -- we model as a set of bitmaps 31 | 32 | (defconstant +map-width+ 26) 33 | (defconstant +map-height+ 29) 34 | 35 | ;; bitmap of which cells are walls and which are not 36 | (defparameter *map-walls* 37 | '(#b00000000000011000000000000 38 | #b01111011111011011111011110 39 | #b01111011111011011111011110 40 | #b01111011111011011111011110 41 | #b00000000000000000000000000 42 | #b01111011011111111011011110 43 | #b01111011011111111011011110 44 | #b00000011000011000011000000 45 | #b11111011111011011111011111 46 | #b11111011111011011111011111 47 | #b11111011000000000011011111 48 | #b11111011011100111011011111 49 | #b11111011010000001011011111 50 | #b00000000010000001000000000 51 | #b11111011010000001011011111 52 | #b11111011011111111011011111 53 | #b11111011000000000011011111 54 | #b11111011011111111011011111 55 | #b11111011011111111011011111 56 | #b00000000000011000000000000 57 | #b01111011111011011111011110 58 | #b01111011111011011111011110 59 | #b00011000000000000000011000 60 | #b11011011011111111011011011 61 | #b11011011011111111011011011 62 | #b00000011000011000011000000 63 | #b01111111111011011111111110 64 | #b01111111111011011111111110 65 | #b00000000000000000000000000)) 66 | 67 | ;; where to place initial dots (but not pellets) 68 | (defparameter *initial-dots* 69 | '(#b11111111111100111111111111 70 | #b10000100000100100000100001 71 | #b00000100000100100000100000 72 | #b10000100000100100000100001 73 | #b11111111111111111111111111 74 | #b10000100100000000100100001 75 | #b10000100100000000100100001 76 | #b11111100111100111100111111 77 | #b00000100000100100000100000 78 | #b00000100000100100000100000 79 | #b00000100000000000000100000 80 | #b00000100000000000000100000 81 | #b00000100000000000000100000 82 | #b00000100000000000000100000 83 | #b00000100000000000000100000 84 | #b00000100000000000000100000 85 | #b00000100000000000000100000 86 | #b00000100000000000000100000 87 | #b00000100000000000000100000 88 | #b11111111111100111111111111 89 | #b10000100000100100000100001 90 | #b10000100000100100000100001 91 | #b01100111111111111111100110 92 | #b00100100100000000100100100 93 | #b00100100100000000100100100 94 | #b11111100111100111100111111 95 | #b10000000000100100000000001 96 | #b10000000000100100000000001 97 | #b11111111111111111111111111)) 98 | 99 | ;; where to draw walls. these are drawn as polygons because their ends meet. 100 | (defparameter *walls* 101 | '(((1 1) (4 1) (4 3) (1 3)) 102 | ((6 1) (10 1) (10 3) (6 3)) 103 | ((15 1) (19 1) (19 3) (15 3)) 104 | ((21 1) (24 1) (24 3) (21 3)) 105 | ((1 5) (4 5) (4 6) (1 6)) 106 | ((6 5) (7 5) (7 8) (10 8) (10 9) (7 9) (7 12) (6 12)) 107 | ((9 5) (16 5) (16 6) (13 6) (13 9) (12 9) (12 6) (9 6)) 108 | ((18 5) (19 5) (19 12) (18 12) (18 9) (15 9) (15 8) (18 8)) 109 | ((21 5) (24 5) (24 6) (21 6)) 110 | ((6 14) (7 14) (7 18) (6 18)) 111 | ((9 17) (16 17) (16 18) (13 18) (13 21) (12 21) (12 18) (9 18)) 112 | ((18 14) (19 14) (19 18) (18 18)) 113 | ((1 20) (4 20) (4 24) (3 24) (3 21) (1 21)) 114 | ((6 20) (10 20) (10 21) (6 21)) 115 | ((15 20) (19 20) (19 21) (15 21)) 116 | ((21 20) (24 20) (24 21) (22 21) (22 24) (21 24)) 117 | ((1 26) (6 26) (6 23) (7 23) (7 26) (10 26) (10 27) (1 27)) 118 | ((9 23) (16 23) (16 24) (13 24) (13 27) (12 27) (12 24) (9 24)) 119 | ((15 26) (18 26) (18 23) (19 23) (19 26) (24 26) (24 27) (15 27)))) 120 | 121 | ;; where to draw edges. these are drawn as lines because their ends don't meet. 122 | (defparameter *map-edges* 123 | '(((-1 12) (4 12) (4 8) (-1 8) (-1 -1) (12 -1) (12 3) (13 3) (13 -1) (26 -1) (26 8) (21 8) (21 12) (26 12)) 124 | ((-1 14) (4 14) (4 18) (-1 18) (-1 23) (1 23) (1 24) (-1 24) (-1 29) (26 29) 125 | (26 24) (24 24) (24 23) (26 23) (26 18) (21 18) (21 14) (26 14)) 126 | ((14 11) (16 11) (16 15) (11 15) (9 15) (9 11) (11 11)))) 127 | 128 | ;; ----------------- game logic --------------------- 129 | 130 | (defun wallp (x y) 131 | "Does this cell have a wall in it? i.e. can ghosts or players pass through it." 132 | (cond 133 | ((and (= y 13) (= x +map-width+)) 134 | nil) 135 | ((and (= y 13) (= x -1)) 136 | nil) 137 | ((and (>= x 0) (< x +map-width+) 138 | (>= y 0) (< y +map-height+)) 139 | (not 140 | (zerop 141 | (logand (nth y *map-walls*) 142 | (ash 1 (- (1- +map-width+) x)))))) 143 | (t t))) 144 | 145 | (defun leftp (x y) 146 | ;; special cases for central tunnels 147 | (cond 148 | ((and (= y 13) (= x 0)) 149 | (1- +map-width+)) 150 | ((= x 0) nil) 151 | ((wallp (1- x) y) nil) 152 | (t (1- x)))) 153 | 154 | (defun rightp (x y) 155 | ;; special cases for central tunnels 156 | (cond 157 | ((and (= y 13) (= x 0)) 158 | (1- +map-width+)) 159 | ((= x (1- +map-width+)) nil) 160 | ((wallp (1+ x) y) nil) 161 | (t (1+ x)))) 162 | 163 | (defun upp (x y) 164 | (cond 165 | ((= y 0) nil) 166 | ((wallp x (1- y)) nil) 167 | (t (1- y)))) 168 | 169 | (defun downp (x y) 170 | (cond 171 | ((= y (1- +map-height+)) nil) 172 | ((wallp x (1+ y)) nil) 173 | (t (1+ y)))) 174 | 175 | (defun dirp (x y dir) 176 | (ecase dir 177 | (:left (leftp x y)) 178 | (:right (rightp x y)) 179 | (:up (upp x y)) 180 | (:down (downp x y)))) 181 | 182 | (defparameter *dots* nil) 183 | (defun init-dots () 184 | (setf *dots* 185 | (make-array (list +map-width+ +map-height+) 186 | :initial-element nil)) 187 | (dotimes (x +map-width+) 188 | (dotimes (y +map-height+) 189 | (unless (zerop 190 | (logand (nth y *initial-dots*) 191 | (ash 1 (- (1- +map-width+) x)))) 192 | (setf (aref *dots* x y) :dot)))) 193 | (setf (aref *dots* 0 2) :pellet 194 | (aref *dots* (1- +map-width+) 2) :pellet 195 | (aref *dots* 0 22) :pellet 196 | (aref *dots* (1- +map-width+) 22) :pellet)) 197 | 198 | (defun dotp (x y) 199 | (unless *dots* (init-dots)) 200 | (eq (aref *dots* x y) :dot)) 201 | (defun pelletp (x y) 202 | (unless *dots* (init-dots)) 203 | (eq (aref *dots* x y) :pellet)) 204 | (defun clear-dot (x y) 205 | (unless *dots* (init-dots)) 206 | (setf (aref *dots* x y) nil)) 207 | 208 | 209 | ;; game state 210 | (defparameter *x* 12) 211 | (defparameter *y* 22) 212 | (defparameter *dir* :right) 213 | (defparameter *try-dir* nil) 214 | (defparameter *score* 0) 215 | (defparameter *mouth* 0.0 216 | "Angle in radians the mouth is open.") 217 | (defparameter *mouth-dir* (/ pi 16.0)) 218 | (defparameter *invincible* nil) 219 | (defparameter *lives* 3) 220 | (defparameter *paused* nil) 221 | 222 | (defun move-mouth () 223 | (incf *mouth* *mouth-dir*) 224 | (cond 225 | ((>= *mouth* (/ pi 4.0)) 226 | (setf *mouth-dir* (- *mouth-dir*) 227 | *mouth* (/ pi 4.0))) 228 | ((<= *mouth* 0) 229 | (setf *mouth-dir* (- *mouth-dir*) 230 | *mouth* 0.0)))) 231 | 232 | (defun move-player (x y) 233 | (ecase *dir* 234 | (:left (setf x (1- x))) 235 | (:right (setf x (1+ x))) 236 | (:up (setf y (1- y))) 237 | (:down (setf y (1+ y)))) 238 | (cond 239 | ((and *try-dir* (dirp *x* *y* *try-dir*)) 240 | (setf *dir* *try-dir* 241 | *try-dir* nil)) 242 | ((not (wallp x y)) 243 | (setf *x* (mod x +map-width+) 244 | *y* y 245 | x *x* 246 | y *y*) 247 | (move-mouth) 248 | 249 | (when (dotp x y) 250 | (clear-dot x y) 251 | (incf *score* 10)) 252 | 253 | (when (pelletp x y) 254 | (clear-dot x y) 255 | (incf *score* 50) 256 | (setf *invincible* 100))))) 257 | 258 | 259 | (defstruct ghost 260 | name x y dir (eyes 0)) 261 | 262 | (defparameter *ghosts* 263 | (list (make-ghost :name :blinky :x 13 :y 13 :dir :up) 264 | (make-ghost :name :pinky :x 13 :y 13 :dir :up) 265 | (make-ghost :name :inky :x 13 :y 13 :dir :up) 266 | (make-ghost :name :clyde :x 13 :y 13 :dir :up))) 267 | 268 | (defun ghost-choose-dir (g) 269 | (let ((dir (ghost-dir g))) 270 | (dolist (d 271 | (ecase dir 272 | ((:up :down) '(:left :right)) 273 | ((:left :right) '(:up :down)))) 274 | (when (dirp (ghost-x g) (ghost-y g) d) 275 | (setf (ghost-dir g) d))))) 276 | 277 | (defun move-ghost (g) 278 | "Move the ghost one place. This is the function which should dispatch 279 | to the AI to decide how to move. Each ghost should have a slightly different 280 | AI personality. 281 | Blinky chases macroman. 282 | Pinky and Inky try to position themselves in front of macroman. 283 | Clyde is random but also chases macroman and moves to lower left when macroman gets to close. 284 | 285 | At the moment it chooses randomly which is pretty bad and makes the game too easy. 286 | " 287 | (let ((x (ghost-x g)) 288 | (y (ghost-y g))) 289 | (ecase (ghost-dir g) 290 | (:left (setf x (1- x))) 291 | (:right (setf x (1+ x))) 292 | (:up (setf y (1- y))) 293 | (:down (setf y (1+ y)))) 294 | (cond 295 | ((wallp x y) 296 | (setf (ghost-dir g) 297 | (nth (random 2) 298 | (ecase (ghost-dir g) 299 | ((:left :right) '(:up :down)) 300 | ((:up :down) '(:left :right)))))) 301 | (t 302 | (setf x (mod x +map-width+)) 303 | (setf (ghost-x g) x 304 | (ghost-y g) y))))) 305 | 306 | (defun init-ghosts () 307 | (setf *ghosts* 308 | (list (make-ghost :name :blinky :x 13 :y 13 :dir :up) 309 | (make-ghost :name :pinky :x 13 :y 13 :dir :up) 310 | (make-ghost :name :inky :x 13 :y 13 :dir :up) 311 | (make-ghost :name :clyde :x 13 :y 13 :dir :up)))) 312 | 313 | (defun new-game () 314 | (init-dots) 315 | (setf *x* 12 316 | *y* 22 317 | *dir* :up 318 | *score* 0 319 | *lives* 3) 320 | (init-ghosts)) 321 | 322 | (defun detect-hits () 323 | (dolist (g *ghosts*) 324 | (let ((x (ghost-x g)) 325 | (y (ghost-y g))) 326 | (when (and (>= x (1- *x*)) (<= x (1+ *x*)) 327 | (>= y (1- *y*)) (<= y (1+ *y*))) 328 | (cond 329 | (*invincible* 330 | ;; kill ghost 331 | (setf (ghost-x g) 13 332 | (ghost-y g) 13) 333 | (incf *score* 150)) 334 | (t 335 | ;; kill player 336 | (decf *lives*) 337 | (setf *x* 12 *y* 22 338 | *invincible* 30) 339 | (init-ghosts) 340 | (when (= *lives* 0) 341 | (new-game)))))))) 342 | 343 | (defun move () 344 | (move-player *x* *y*) 345 | (dolist (g *ghosts*) 346 | (move-ghost g)) 347 | (detect-hits)) 348 | 349 | 350 | 351 | 352 | 353 | ;; ------------- GUI --------------- 354 | 355 | (defun macroman-create (hwnd) 356 | (new-game) 357 | (set-timer :hwnd hwnd 358 | :elapse 75 359 | :replace-timer 1)) 360 | 361 | (defconstant +left-margin+ 100) 362 | (defconstant +top-margin+ 100) 363 | (defconstant +width+ 12) 364 | (defconstant +height+ 15) 365 | 366 | (defun translate-point (p) 367 | (destructuring-bind (x y) p 368 | (list (+ +left-margin+ (truncate +width+ 2) (* x +width+)) 369 | (+ +top-margin+ (truncate +height+ 2) (* y +height+))))) 370 | 371 | (defun draw-wall (hdc wall-points) 372 | (select-object hdc (get-stock-object :black-brush)) 373 | (select-object hdc (get-stock-object :white-pen)) 374 | (polygon hdc (mapcar #'translate-point wall-points))) 375 | 376 | (defun draw-map-edge (hdc points) 377 | (select-object hdc (get-stock-object :black-brush)) 378 | (select-object hdc (get-stock-object :white-pen)) 379 | (polyline hdc (mapcar #'translate-point points))) 380 | 381 | (defun draw-cell (hdc x y) 382 | (select-object hdc (get-stock-object :black-brush)) 383 | (rectangle hdc 384 | (+ +left-margin+ (* x +width+)) 385 | (+ +top-margin+ (* y +height+)) 386 | (+ +left-margin+ (* (1+ x) +width+)) 387 | (+ +top-margin+ (* (1+ y) +height+)))) 388 | 389 | (defun draw-dot (hdc x y) 390 | (select-object hdc (get-stock-object :grey-brush)) 391 | (ellipse hdc 392 | (+ +left-margin+ (- (truncate +width+ 2) 3) (* x +width+)) 393 | (+ +top-margin+ (- (truncate +height+ 2) 3) (* y +height+)) 394 | (+ +left-margin+ (+ (truncate +width+ 2) 3) (* x +width+)) 395 | (+ +top-margin+ (+ (truncate +height+ 2) 3) (* y +height+)))) 396 | 397 | (defun draw-pellet (hdc x y) 398 | (select-object hdc (get-stock-object :grey-brush)) 399 | (ellipse hdc 400 | (+ +left-margin+ (* x +width+)) 401 | (+ +top-margin+ (* y +height+)) 402 | (+ +left-margin+ +width+ (* x +width+)) 403 | (+ +top-margin+ +width+ (* y +height+)))) 404 | 405 | (defun draw-block (hdc x y) 406 | (select-object hdc (get-stock-object :black-pen)) 407 | (draw-cell hdc x y) 408 | (when (dotp x y) 409 | (draw-dot hdc x y)) 410 | (when (pelletp x y) 411 | (draw-pellet hdc x y))) 412 | 413 | 414 | ;; To draw the player we draw a pie shape. The wedge needs to be taken out of 415 | ;; the top/right/bottom/left depending on the directio nthe character is moving 416 | (defun draw-player (hdc) 417 | (if (and *invincible* (zerop (mod *invincible* 2))) 418 | (select-object hdc (get-stock-object :gray-brush)) 419 | (select-object hdc (get-stock-object :white-brush))) 420 | 421 | (let* ((theta (ecase *dir* 422 | (:left (- pi)) 423 | (:right 0) 424 | (:up (- (/ pi 2))) 425 | (:down (/ pi 2)))) 426 | (radius (truncate (+ 5 (truncate (* 3/2 +width+))) 2)) 427 | (x (+ +left-margin+ (* *x* +width+) radius)) 428 | (y (+ +top-margin+ (* *y* +height+) radius)) 429 | 430 | (left (- x radius)) 431 | (top (- y radius)) 432 | (right (+ x radius)) 433 | (bottom (+ y radius))) 434 | (pie hdc 435 | left top right bottom 436 | (truncate (+ x (* radius (cos (- theta *mouth*))))) 437 | (truncate (+ y (* radius (sin (- theta *mouth*))))) 438 | (truncate (+ x (* radius (cos (+ theta *mouth*))))) 439 | (truncate (+ y (* radius (sin (+ theta *mouth*)))))))) 440 | 441 | 442 | (defun draw-score (hdc) 443 | (set-bk-mode hdc :transparent) 444 | (set-text-color hdc (encode-rgb 255 255 255)) 445 | (text-out hdc "HIGH SCORE" 300 25) 446 | (text-out hdc (format nil "~A" *score*) 325 50) 447 | (text-out hdc "ONE UP" 150 25) 448 | (text-out hdc (format nil "~A" *lives*) 175 50) 449 | (when *paused* (text-out hdc "PAUSED" 225 60))) 450 | 451 | (defun draw-ghost (hdc g) 452 | (let* ((brush (create-solid-brush 453 | (if *invincible* 454 | (if (zerop (mod *invincible* 2)) 455 | (encode-rgb 0 0 235) 456 | (encode-rgb 198 193 182)) 457 | (ecase (ghost-name g) 458 | (:blinky (encode-rgb 236 0 0)) 459 | (:pinky (encode-rgb 255 87 225)) 460 | (:inky (encode-rgb 3 198 215)) 461 | (:clyde (encode-rgb 248 188 45)))))) 462 | (hold-brush (select-object hdc brush)) 463 | (x (ghost-x g)) 464 | (y (ghost-y g)) 465 | (px (first (translate-point (list x y)))) 466 | (py (second (translate-point (list x y))))) 467 | (select-object hdc (get-stock-object :white-pen)) 468 | ;; (ellipse hdc 469 | ;; (+ +left-margin+ (* x +width+) (- (truncate +width+ 3))) 470 | ;; (+ +top-margin+ (* y +height+) (- (truncate +height+ 7))) 471 | ;; (+ +left-margin+ (* x +width+) +width+ (+ (truncate +width+ 3))) 472 | ;; (+ +top-margin+ (* y +height+) +height+ (truncate +height+ 7))) 473 | 474 | 475 | (polygon hdc 476 | (mapcar (lambda (p) 477 | (list (+ (first p) px (- +width+)) 478 | (+ (second p) py (- +height+)))) 479 | '((15 5) (16 6) (17 7) (18 7) (20 8) (21 9) (22 10) (23 14) (24 21) (25 25) 480 | (25 25) (22 20) (18 25) (18 20) (12 20) (12 25) (8 20) (5 25) 481 | (5 25) (6 20) (7 14) (8 10) (9 9) (10 8) (12 7) (13 7) (14 6) (15 5)))) 482 | 483 | (select-object hdc hold-brush) 484 | (delete-object brush) 485 | 486 | (select-object hdc (get-stock-object :white-brush)) 487 | (ellipse hdc (+ px -2) (+ py -6) (+ px 3) (+ py 2)) 488 | (ellipse hdc (+ px 4) (+ py -6) (+ px 9) (+ py 2)) 489 | 490 | (select-object hdc (get-stock-object :black-brush)) 491 | (select-object hdc (get-stock-object :black-pen)) 492 | (cond 493 | ((< (ghost-eyes g) 5) 494 | (ellipse hdc (+ px -2) (+ py -5) (+ px 0) (+ py 0)) 495 | (ellipse hdc (+ px 2) (+ py -5) (+ px 4) (+ py 0))) 496 | ((< (ghost-eyes g) 10) 497 | (ellipse hdc (+ px 2) (+ py -5) (+ px 2) (+ py 0)) 498 | (ellipse hdc (+ px 7) (+ py -5) (+ px 9) (+ py 0)))) 499 | (incf (ghost-eyes g)) 500 | (when (> (ghost-eyes g) 10) 501 | (setf (ghost-eyes g) 0)) 502 | 503 | )) 504 | 505 | 506 | 507 | (defun macroman-paint (hwnd) 508 | (with-double-buffering (hdc hwnd) 509 | (dotimes (x +map-width+) 510 | (dotimes (y +map-height+) 511 | (draw-block hdc x y))) 512 | (dolist (wall-points *walls*) 513 | (draw-wall hdc wall-points)) 514 | (dolist (edge-points *map-edges*) 515 | (draw-map-edge hdc edge-points)) 516 | (draw-player hdc) 517 | (draw-score hdc) 518 | (dolist (g *ghosts*) 519 | (draw-ghost hdc g)))) 520 | 521 | 522 | (defun macroman-timer (hwnd) 523 | (unless *paused* 524 | (move) 525 | (when *invincible* 526 | (decf *invincible*) 527 | (when (zerop *invincible*) 528 | (setf *invincible* nil)))) 529 | (invalidate-rect hwnd nil t)) 530 | 531 | (defun macroman-keydown (hwnd wparam) 532 | (let ((key (virtual-code-key wparam))) 533 | (case key 534 | ((:left :right :up :down) 535 | (setf *try-dir* key)) 536 | (:keyq (destroy-window hwnd)) 537 | (:keyn (new-game)) 538 | (:keyp (setf *paused* (not *paused*))) 539 | (:keyh 540 | (setf *paused* t) 541 | (message-box :hwnd hwnd 542 | :text " 543 | Macroman - pacman type game written in Common Lisp. 544 | Copyright (c) Frank James 2016. 545 | 546 | Controls: 547 | left right up down Move macroman. 548 | P Pause/unpause game. 549 | N New game. 550 | Q Quit. 551 | H This message. 552 | " 553 | :caption "Help" 554 | :icon :information) 555 | (setf *paused* nil))))) 556 | 557 | (defwndproc macroman-wndproc (hwnd msg wparam lparam) 558 | (switch msg 559 | ((const +wm-create+) 560 | (macroman-create hwnd)) 561 | ((const +wm-destroy+) 562 | (post-quit-message)) 563 | ((const +wm-paint+) 564 | (macroman-paint hwnd)) 565 | ((const +wm-timer+) 566 | (macroman-timer hwnd)) 567 | ((const +wm-keydown+) 568 | (macroman-keydown hwnd wparam))) 569 | 570 | (default-window-proc hwnd msg wparam lparam)) 571 | 572 | (defun macroman () 573 | (default-message-loop (cffi:callback macroman-wndproc) 574 | :class-name "FTW_MACROMAN" 575 | :title "Macroman" 576 | :width 500 :height 650 577 | :background (get-stock-object :black-brush))) 578 | -------------------------------------------------------------------------------- /examples/minesweeper/minesweeper.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; Simple minesweeper game 5 | ;;; Things which could be done and are left as an exercise to the reader: 6 | ;;; 1. Adding icons/images instead of using text for the numbers, mines and flags. 7 | ;;; 2. Keeping a high-score list saved away e.g. in current user's home directory. 8 | ;;; 3. Writing a proper "about" dialog. 9 | ;;; 4. Dialog for entering arbitrary game sizes. 10 | ;;; 5. Automatically clicking on provable empty cells 11 | ;;; 6. Win detection 12 | ;;; 7. Automatically resizing main window to the size of the game board 13 | 14 | 15 | (defpackage #:ftw.minesweeper 16 | (:use #:cl #:cffi #:ftw) 17 | (:export #:minesweeper)) 18 | 19 | (in-package #:ftw.minesweeper) 20 | 21 | 22 | (defstruct minesweeper 23 | x y 24 | cells 25 | flags 26 | finished 27 | seconds) 28 | 29 | (defun cell (ms x y) 30 | (aref (minesweeper-cells ms) y x)) 31 | (defun (setf cell) (value ms x y) 32 | (setf (aref (minesweeper-cells ms) y x) value)) 33 | 34 | (defun set-flag (ms x y &optional set) 35 | (if set 36 | (pushnew :flag (cell ms x y)) 37 | (setf (cell ms x y) 38 | (remove :flag (cell ms x y))))) 39 | 40 | (defun flag-p (ms x y) 41 | (member :flag (cell ms x y))) 42 | 43 | (defun mine-p (ms x y) 44 | (member :mine (cell ms x y))) 45 | 46 | (defun mines (ms x y) 47 | (let ((m 0)) 48 | (do ((i (1- x) (1+ i))) 49 | ((> i (1+ x))) 50 | (do ((j (1- y) (1+ j))) 51 | ((> j (1+ y))) 52 | (when (and (>= i 0) (< i (minesweeper-x ms))) 53 | (when (and (>= j 0) (< j (minesweeper-y ms))) 54 | (unless (and (= i x) (= j y)) 55 | (when (mine-p ms i j) 56 | (incf m))))))) 57 | m)) 58 | 59 | 60 | (defvar *starting-mines* 10) 61 | (defvar *starting-x* 10) 62 | (defvar *starting-y* 10) 63 | (defvar *ms* nil) 64 | 65 | (defun random-game (&key x y mines) 66 | (unless x (setf x *starting-x*)) 67 | (unless y (setf y *starting-y*)) 68 | (unless mines (setf mines *starting-mines*)) 69 | 70 | (let ((ms (make-minesweeper 71 | :x x :y y 72 | :cells (make-array (list x y) 73 | :element-type t 74 | :initial-contents 75 | (let ((m mines)) 76 | (loop :for i :below x :collect 77 | (loop :for j :below y :collect 78 | (let ((left (- (* x y) (+ (* i y) j)))) 79 | (cond 80 | ((or (zerop left) (zerop m)) nil) 81 | ((<= left m) 82 | (decf m) 83 | (list :mine)) 84 | ((<= (random left) m) 85 | (decf m) 86 | (list :mine)) 87 | (t nil))))))) 88 | :flags mines 89 | :seconds 0))) 90 | ms)) 91 | 92 | 93 | (defun clicked-p (ms x y) 94 | (integerp (car (cell ms x y)))) 95 | 96 | (defun unclicked-neighbours (ms x y) 97 | (let ((neighbours nil)) 98 | (do ((i (1- x) (1+ i))) 99 | ((= i (+ x 2))) 100 | (do ((j (1- y) (1+ j))) 101 | ((= j (+ y 2))) 102 | (when (and (>= i 0) (< i (minesweeper-x ms)) 103 | (>= j 0) (< j (minesweeper-y ms)) 104 | (not (and (= i x) (= j y))) 105 | (not (clicked-p ms i j))) 106 | (push (list i j) neighbours)))) 107 | neighbours)) 108 | 109 | 110 | (defun click-provable-cells (ms x y) 111 | "If this location has a mine count of 0 then 112 | look at all the unclicked cells around this location and click those too. 113 | Repeat recursively." 114 | (when (= (mines ms x y) 0) 115 | (dolist (n (unclicked-neighbours ms x y)) 116 | (click-cell ms (first n) (second n))))) 117 | 118 | (defun click-cell (ms x y) 119 | (cond 120 | ((mine-p ms x y) 121 | :mine) 122 | (t 123 | (setf (cell ms x y) (list (mines ms x y))) 124 | (click-provable-cells ms x y) 125 | (cell ms x y)))) 126 | 127 | (defun resize-window (hwnd) 128 | "Set the window to the size required for the game" 129 | (let ((w (minesweeper-x *ms*)) 130 | (h (minesweeper-y *ms*))) 131 | (set-window-pos hwnd :top 132 | 0 0 133 | (+ 100 (* w 25)) 134 | (+ 175 (* h 25)) 135 | '(:no-move)))) 136 | 137 | (defun game-won-p () 138 | "Returns true if all mines have a flag placed on them." 139 | (let ((mines 0) 140 | (correct 0)) 141 | (dotimes (i (minesweeper-x *ms*)) 142 | (dotimes (j (minesweeper-y *ms*)) 143 | (when (mine-p *ms* i j) 144 | (incf mines) 145 | (when (flag-p *ms* i j) 146 | (incf correct))))) 147 | (= mines correct))) 148 | 149 | ;; I made a little icon in gimp and exported it as a microsoft icon (*.ico) file. 150 | ;; Then I ran generate-icon-resource on that file. I pasted the output below. 151 | (defvar *MINE-ICON* 152 | (create-icon 32 32 1 32 153 | (make-array 4224 :element-type '(unsigned-byte 8)) 154 | #(#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 155 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 156 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 157 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 158 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 159 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 160 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 161 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 162 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 163 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 164 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 165 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 166 | #x00 #x00 #x00 #xFC #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 167 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 168 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 169 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 170 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 171 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 172 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 173 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x5F 174 | #x00 #x00 #x00 #xD5 #x00 #x00 #x00 #x3E #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 175 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 176 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 177 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 178 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 179 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 180 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 181 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x77 182 | #x00 #x00 #x00 #xB6 #x00 #x00 #x00 #x5A #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 183 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 184 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 185 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 186 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 187 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 188 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 189 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xE9 190 | #x00 #x00 #x00 #xF3 #x00 #x00 #x00 #xF3 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 191 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 192 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 193 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 194 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 195 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xAA #x00 #x00 #x00 #x00 196 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 197 | #x00 #x00 #x00 #x35 #x00 #x00 #x00 #x83 #x00 #x00 #x00 #xCA #x00 #x00 #x00 #xF5 198 | #x00 #x00 #x00 #xF5 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x83 #x00 #x00 #x00 #x35 199 | #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 200 | #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 201 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 202 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 203 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xCE 204 | #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x56 #x00 #x00 #x00 #xFF 205 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 206 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 207 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x56 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 208 | #x00 #x00 #x00 #x6C #x00 #x00 #x00 #xAA #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 209 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 210 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 211 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 212 | #x00 #x00 #x00 #xE4 #x00 #x00 #x00 #xC3 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 213 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 214 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 215 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xC3 #x00 #x00 #x00 #xB0 216 | #x00 #x00 #x00 #xAA #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 217 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 218 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 219 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x13 220 | #x00 #x00 #x00 #xFA #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 221 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 222 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 223 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xF7 224 | #x00 #x00 #x00 #x13 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 225 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 226 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 227 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #xD3 228 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 229 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 230 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 231 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 232 | #x00 #x00 #x00 #xD3 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 233 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 234 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 235 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6B #x00 #x00 #x00 #xFF 236 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 237 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 238 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 239 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 240 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x6B #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 241 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 242 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 243 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 244 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 245 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 246 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 247 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 248 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x00 249 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 250 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 251 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x4A #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 252 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 253 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 254 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 255 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 256 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x4A #x00 #x00 #x00 #x00 257 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 258 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 259 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x9E #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 260 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 261 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 262 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 263 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 264 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x9E #x00 #x00 #x00 #x00 265 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 266 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6F 267 | #x00 #x00 #x00 #xAE #x00 #x00 #x00 #xE0 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 268 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 269 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x17 #x17 #x17 #xFF 270 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 271 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 272 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xE0 #x00 #x00 #x00 #xDA 273 | #x00 #x00 #x00 #x53 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 274 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xF3 #x00 #x00 #x00 #xCA 275 | #x00 #x00 #x00 #xE9 #x00 #x00 #x00 #xFB #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 276 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 277 | #x17 #x17 #x17 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 278 | #x17 #x17 #x17 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 279 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 280 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFB #x00 #x00 #x00 #xD5 281 | #x00 #x00 #x00 #xA3 #x00 #x00 #x00 #xFC #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x00 282 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xAE 283 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xE0 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 284 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x17 #x17 #x17 #xFF #x17 #x17 #x17 #xFF 285 | #x37 #x37 #x37 #xFF #x37 #x37 #x37 #xFF #x37 #x37 #x37 #xFF #x37 #x37 #x37 #xFF 286 | #x37 #x37 #x37 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 287 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 288 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xE0 #x00 #x00 #x00 #xDF 289 | #x00 #x00 #x00 #x98 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 290 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 291 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x9E #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 292 | #x00 #x00 #x00 #xFF #x17 #x17 #x17 #xFF #x17 #x17 #x17 #xFF #x37 #x37 #x37 #xFF 293 | #x37 #x37 #x37 #xFF #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF 294 | #x37 #x37 #x37 #xFF #x37 #x37 #x37 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 295 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 296 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x9E #x00 #x00 #x00 #x00 297 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 298 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 299 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x4A #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 300 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x37 #x37 #x37 #xFF #x5B #x5B #x5B #xFF 301 | #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF 302 | #x5B #x5B #x5B #xFF #x37 #x37 #x37 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 303 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 304 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x4A #x00 #x00 #x00 #x00 305 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 306 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 307 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 308 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x88 #x88 #x88 #xFF #x88 #x88 #x88 #xFF 309 | #x5B #x5B #x5B #xFF #x88 #x88 #x88 #xFF #x5B #x5B #x5B #xFF #x5B #x5B #x5B #xFF 310 | #x5B #x5B #x5B #xFF #x17 #x17 #x17 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 311 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 312 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x00 313 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 314 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 315 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6B #x00 #x00 #x00 #xFF 316 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x37 #x37 #x37 #xFF #x88 #x88 #x88 #xFF 317 | #x88 #x88 #x88 #xFF #x88 #x88 #x88 #xFF #x88 #x88 #x88 #xFF #x5B #x5B #x5B #xFF 318 | #x5B #x5B #x5B #xFF #x17 #x17 #x17 #xFF #x17 #x17 #x17 #xFF #x00 #x00 #x00 #xFF 319 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 320 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x6B #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 321 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 322 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 323 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #xD3 324 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x37 #x37 #x37 #xFF 325 | #x88 #x88 #x88 #xFF #x88 #x88 #x88 #xFF #xC7 #xC7 #xC7 #xFF #x5B #x5B #x5B #xFF 326 | #x37 #x37 #x37 #xFF #x17 #x17 #x17 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 327 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 328 | #x00 #x00 #x00 #xD3 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 329 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 330 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 331 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x13 332 | #x00 #x00 #x00 #xFC #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 333 | #x00 #x00 #x00 #xFF #x37 #x37 #x37 #xFF #x88 #x88 #x88 #xFF #x49 #x49 #x49 #xFF 334 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 335 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xF7 336 | #x00 #x00 #x00 #x77 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 337 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 338 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 339 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xAA 340 | #x00 #x00 #x00 #x76 #x00 #x00 #x00 #xC3 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 341 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 342 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 343 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xC3 #x00 #x00 #x00 #xB0 344 | #x00 #x00 #x00 #x6C #x00 #x00 #x00 #xAA #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 345 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 346 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 347 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x6C 348 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x56 #x00 #x00 #x00 #xFF 349 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 350 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF 351 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x56 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 352 | #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 353 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 354 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 355 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 356 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 357 | #x00 #x00 #x00 #x35 #x00 #x00 #x00 #x83 #x00 #x00 #x00 #xCA #x00 #x00 #x00 #xF5 358 | #x00 #x00 #x00 #xF5 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x83 #x00 #x00 #x00 #x35 359 | #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 360 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 361 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 362 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 363 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 364 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 365 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF 366 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 367 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 368 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 369 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 370 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 371 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 372 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 373 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xCC 374 | #x00 #x00 #x00 #xCC #x00 #x00 #x00 #x73 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 375 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 376 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 377 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 378 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 379 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 380 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 381 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xC1 382 | #x00 #x00 #x00 #xF3 #x00 #x00 #x00 #x98 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 383 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 384 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 385 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 386 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 387 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 388 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 389 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 390 | #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 391 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 392 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 393 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 394 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 395 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 396 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 397 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 398 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 399 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 400 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 401 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 402 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 403 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 404 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 405 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 406 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 407 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 408 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 409 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 410 | #xFF #xFF #xFF #xFF #xFF #xFF #x7F #xFF #xFF #xFE #x3F #xFF #xFF #xFE #x3F #xFF 411 | #xFF #xFE #x3F #xFF #xFD #xE0 #x07 #x3F #xFE #x00 #x01 #x3F #xFF #x00 #x00 #x3F 412 | #xFE #x00 #x00 #x7F #xFC #x00 #x00 #x3F #xFC #x00 #x00 #x3F #xF8 #x00 #x00 #x1F 413 | #xF8 #x00 #x00 #x1F #xF8 #x00 #x00 #x1F #xE0 #x00 #x00 #x07 #x80 #x00 #x00 #x01 414 | #xE0 #x00 #x00 #x07 #xF8 #x00 #x00 #x1F #xF8 #x00 #x00 #x1F #xF8 #x00 #x00 #x1F 415 | #xFC #x00 #x00 #x3F #xFC #x00 #x00 #x3F #xFE #x00 #x00 #x7F #xFE #x00 #x00 #x3F 416 | #xFC #x80 #x01 #x3F #xFF #xE0 #x07 #xBF #xFF #xFE #x3F #xFF #xFF #xFE #x3F #xFF 417 | #xFF #xFE #x3F #xFF #xFF #xFF #x7F #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF ))) 418 | 419 | (defwndproc minesweeper-wndproc (hwnd msg wparam lparam) 420 | (switch msg 421 | ((const +wm-create+) 422 | (setf *ms* (random-game)) 423 | (resize-window hwnd) 424 | 425 | ;; add menus 426 | (add-menu-bar hwnd 427 | `((:menu (:popup) :name "&Game" 428 | :children 429 | ((:item (:string) 430 | :name ,(format nil "&New~ACtrl+N" #\tab) 431 | :id 1) 432 | (:item (:separator)) 433 | (:item (:string) 434 | :name "Beginner" :id 6) 435 | (:item (:string) 436 | :name "Advanced" :id 7) 437 | (:item (:string) 438 | :name "Expert" :id 8) 439 | (:radio (6 8) :id 6) 440 | (:item (:separator)) 441 | (:item (:string) 442 | :name ,(format nil "&Quit~ACtrl+Q" #\tab) 443 | :id 2))) 444 | (:menu (:popup) :name "&Help" 445 | :children 446 | ((:item (:string) 447 | :name "&About" 448 | :id 3))))) 449 | 450 | (let ((right (getf (get-client-rect hwnd) :right 0))) 451 | (create-window :button 452 | :window-name "New" 453 | :styles (logior-consts +ws-visible+ +ws-child+ +bs-pushbutton+) 454 | :x (truncate right 2) :y 20 :width 45 :height 22 455 | :parent hwnd 456 | :menu 5)) 457 | 458 | ;; create accelerator table 459 | (set-accelerator-table 460 | '((:keyn 1 :control :virtual-key) 461 | (:keyq 2 :control :virtual-key))) 462 | 463 | (set-timer :hwnd hwnd :elapse 1000 :replace-timer 4)) 464 | ((const +wm-paint+) 465 | (with-paint (hwnd hdc) 466 | (set-bk-mode hdc :transparent) 467 | ;; draw top region containing seconds and flag counter 468 | (destructuring-bind (&key (right 0) (bottom 0) &allow-other-keys) (get-client-rect hwnd) 469 | (draw-edge hdc (make-rect :left 10 :top 10 :right (- right 10) :bottom 50) 470 | :flags '(:left :right :top :bottom :adjust)) 471 | (text-out hdc (format nil "~A" (minesweeper-seconds *ms*)) 472 | 25 20) 473 | (text-out hdc (format nil "~A" (minesweeper-flags *ms*)) 474 | (- right 40) 20) 475 | 476 | (draw-edge hdc (make-rect :left 10 :top 70 :right (- right 10) :bottom (- bottom 5)) 477 | :flags '(:left :right :top :bottom :adjust)) 478 | 479 | 480 | (let ((xstart (- (truncate right 2) 481 | (* (truncate (minesweeper-x *ms*) 2) 25))) 482 | (ystart 85)) 483 | 484 | (dotimes (i (minesweeper-x *ms*)) 485 | (dotimes (j (minesweeper-y *ms*)) 486 | (draw-edge hdc (make-rect :left (+ xstart (* i 25)) 487 | :top (+ ystart (* j 25)) 488 | :right (+ xstart 25 (* i 25)) 489 | :bottom (+ ystart 25 (* j 25))) 490 | :inner-edge (if (or (clicked-p *ms* i j) (minesweeper-finished *ms*)) 491 | :sunk 492 | :raised) 493 | :outer-edge (if (or (clicked-p *ms* i j) (minesweeper-finished *ms*)) 494 | :sunk 495 | :raised) 496 | :flags '(:left :right :top :bottom :adjust)) 497 | (cond 498 | ((minesweeper-finished *ms*) 499 | (cond 500 | ((mine-p *ms* i j) 501 | (text-out hdc "M" (+ xstart 9 (* i 25)) (+ ystart 5 (* j 25)))) 502 | (t 503 | (let ((m (mines *ms* i j))) 504 | (unless (zerop m) 505 | (text-out hdc (format nil "~A" m) 506 | (+ xstart 9 (* i 25)) 507 | (+ ystart 5 (* j 25)))))))) 508 | (t 509 | (when (flag-p *ms* i j) 510 | (text-out hdc "F" (+ xstart 9 (* i 25)) (+ ystart 5 (* j 25)))) 511 | (when (clicked-p *ms* i j) 512 | (let ((m (mines *ms* i j))) 513 | (unless (zerop m) 514 | (text-out hdc (format nil "~A" m) 515 | (+ xstart 9 (* i 25)) 516 | (+ ystart 5 (* j 25)))))))))))))) 517 | ((const +wm-lbuttondown+) 518 | (destructuring-bind (&key (right 0) &allow-other-keys) (get-client-rect hwnd) 519 | (let* ((xstart (- (truncate right 2) 520 | (* (truncate (minesweeper-x *ms*) 2) 25))) 521 | (ystart 85) 522 | (x (loword lparam)) 523 | (y (hiword lparam)) 524 | (i (truncate (- x xstart) 25)) 525 | (j (truncate (- y ystart) 25))) 526 | (when (= (loword wparam) 1) 527 | (when (and (>= i 0) (< i (minesweeper-x *ms*)) 528 | (>= j 0) (< j (minesweeper-y *ms*))) 529 | (unless (flag-p *ms* i j) 530 | (when (eq (click-cell *ms* i j) :mine) 531 | (setf (minesweeper-finished *ms*) t)))))) 532 | (invalidate-rect hwnd nil t))) 533 | ((const +wm-rbuttondown+) 534 | (destructuring-bind (&key (right 0) &allow-other-keys) (get-client-rect hwnd) 535 | (let* ((xstart (- (truncate right 2) 536 | (* (truncate (minesweeper-x *ms*) 2) 25))) 537 | (ystart 85) 538 | (x (loword lparam)) 539 | (y (hiword lparam)) 540 | (i (truncate (- x xstart) 25)) 541 | (j (truncate (- y ystart) 25))) 542 | (when (= (loword wparam) 2) 543 | (when (and (>= i 0) (< i (minesweeper-x *ms*)) 544 | (>= j 0) (< j (minesweeper-y *ms*)) 545 | (not (clicked-p *ms* i j))) 546 | (cond 547 | ((flag-p *ms* i j) 548 | (set-flag *ms* i j nil) 549 | (incf (minesweeper-flags *ms*))) 550 | (t 551 | (when (> (minesweeper-flags *ms*) 0) 552 | (set-flag *ms* i j t) 553 | (decf (minesweeper-flags *ms*)) 554 | (when (game-won-p) 555 | (setf (minesweeper-finished *ms*) t) 556 | (message-box :hwnd hwnd 557 | :text "You won!" 558 | :caption "Win")))))))) 559 | (invalidate-rect hwnd nil t))) 560 | ((const +wm-command+) 561 | (switch (loword wparam) 562 | (1 ;; new 563 | (setf *ms* (random-game)) 564 | (resize-window hwnd) 565 | (invalidate-rect hwnd nil t)) 566 | (2 ;; quit 567 | (destroy-window hwnd)) 568 | (3 ;; about 569 | (message-box :hwnd hwnd 570 | :text "Simple minesweeper game written in Common Lisp. 571 | 572 | Copyright (c) Frank James 2016. 573 | " 574 | :caption "About")) 575 | (5 ;; new 576 | (setf *ms* (random-game)) 577 | (resize-window hwnd) 578 | (invalidate-rect hwnd nil t)) 579 | (6 ;; beginner 580 | (setf *starting-mines* 10 581 | *starting-x* 10 582 | *starting-y* 10) 583 | (check-menu-radio-item (get-menu hwnd) 6 8 6)) 584 | (7 ;; advanced 585 | (setf *starting-mines* 40 586 | *starting-x* 14 587 | *starting-y* 14) 588 | (check-menu-radio-item (get-menu hwnd) 6 8 7)) 589 | (8 ;; expert 590 | (setf *starting-mines* 99 591 | *starting-x* 24 592 | *starting-y* 24) 593 | (check-menu-radio-item (get-menu hwnd) 6 8 8)))) 594 | ((const +wm-timer+) 595 | (unless (minesweeper-finished *ms*) 596 | (incf (minesweeper-seconds *ms*))) 597 | (invalidate-rect hwnd (make-rect :right 50 598 | :bottom 50) 599 | t)) 600 | ((const +wm-size+) 601 | (let ((btn (find-window "button" "New" hwnd))) 602 | (when btn 603 | (set-window-pos btn :top 604 | (- (truncate (getf (get-client-rect hwnd) :right 0) 2) 22) 605 | 20 606 | 45 22))) 607 | (invalidate-rect hwnd nil t)) 608 | ((const +wm-destroy+) 609 | (set-accelerator-table) 610 | (post-quit-message))) 611 | (default-window-proc hwnd msg wparam lparam)) 612 | 613 | 614 | (defun minesweeper () 615 | (default-message-loop (callback minesweeper-wndproc) 616 | :class-name "FTW_MINESWEEPER" 617 | :title "Minesweeper" 618 | :width 350 :height 425 619 | :icon *mine-icon* 620 | :icon-small *mine-icon*)) 621 | 622 | 623 | 624 | -------------------------------------------------------------------------------- /examples/pong/pong.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | (defpackage #:ftw.pong 5 | (:use #:cl #:cffi #:ftw)) 6 | 7 | (in-package #:ftw.pong) 8 | 9 | ;;; This file should define a simple pong type game. 10 | ;;; It needs to do the following: 11 | ;;; - run a timer, on each tick update the screen i.e. repaint 12 | ;;; - intercept keystrokes to for up and down keys 13 | 14 | (defparameter *timestep* 1.0) 15 | (defparameter *friction* -0.01) 16 | (defparameter *pad-height* 0.2) 17 | (defparameter *pad-width* 0.05) 18 | (defparameter *pad-height-phys* 50) 19 | (defparameter *pad-width-phys* 25) 20 | (defparameter *ball-width* 0.05) 21 | (defparameter *ball-width-phys* 15) 22 | 23 | (defstruct pos 24 | (x 0) 25 | (y 0) 26 | (vx 0) 27 | (vy 0) 28 | (ax *friction*) 29 | (ay *friction*)) 30 | 31 | ;; x'' = a 32 | ;; x' = at (v0 = 0) 33 | ;; x = at^2/2 (x0 = 0) 34 | (defun update-pos (p) 35 | (incf (pos-x p) (* *timestep* (pos-vx p))) 36 | (incf (pos-y p) (* *timestep* (pos-vy p))) 37 | (incf (pos-vx p) (* *timestep* (pos-vx p) (pos-ax p))) 38 | (incf (pos-vy p) (* *timestep* (pos-vy p) (pos-ay p)))) 39 | 40 | 41 | (defparameter *phys-x* 300) 42 | (defparameter *phys-y* 300) 43 | (defparameter *log-x* 1.0) 44 | (defparameter *log-y* 1.0) 45 | 46 | (defun pos-physical (p) 47 | (make-pos :x (truncate (* (pos-x p) (/ *phys-x* *log-x*))) 48 | :y (truncate (* (pos-y p) (/ *phys-y* *log-y*))) 49 | :vx (truncate (* (pos-vx p) (/ *phys-x* *log-x*))) 50 | :vy (truncate (* (pos-vy p) (/ *phys-y* *log-y*))))) 51 | 52 | 53 | (defparameter *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)) 54 | (defparameter *p2* (make-pos :x 0.8 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)) 55 | (defparameter *ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0)) 56 | 57 | (defun reset-game () 58 | (setf *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*) 59 | *p2* (make-pos :x 0.9 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*) 60 | *ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0))) 61 | 62 | (defun update-game () 63 | (let ((items (list *p1* *p2* *ball*))) 64 | ;; update all positions 65 | (dolist (item items) 66 | (update-pos item)) 67 | 68 | (when (< (pos-y *p2*) (pos-y *ball*)) 69 | (setf (pos-vy *p2*) 0.005)) 70 | (when (> (pos-y *p2*) (pos-y *ball*)) 71 | (setf (pos-vy *p2*) -0.005)) 72 | 73 | ;; detect collisions -- disallow p1 and p2 from going outside screen 74 | ;; and invert velicity of ball if contacts p1 or p2 75 | (dolist (p (list *p1* *p2*)) 76 | (when (> (+ (pos-y p) *pad-height*) *log-y*) 77 | (setf (pos-y p) (- *log-y* *pad-height*) 78 | (pos-vy p) 0)) 79 | (when (< (pos-y p) 0) 80 | (setf (pos-y p) 0 81 | (pos-vy p) 0)) 82 | 83 | (when (and (>= (+ (pos-x *ball*) *ball-width*) 84 | (pos-x p)) 85 | (<= (pos-x *ball*) 86 | (+ (pos-x p) *pad-width*)) 87 | (>= (+ (pos-y *ball*) *ball-width*) 88 | (pos-y p)) 89 | (<= (pos-y *ball*) 90 | (+ (pos-y p) *pad-height*))) 91 | 92 | (let* ((dy (- (/ (- (+ (pos-y p) *pad-height*) 93 | (+ (pos-y *ball*) *ball-width*)) 94 | *pad-height*) 95 | 0.5)) 96 | (fx (cos dy)) 97 | (fy (sin dy)) 98 | (f (sqrt (+ (* fx fx) (* fy fy))))) 99 | ;; adjust velocities 100 | ;; FIXME: this needs touching up because the mechanics aren't right, 101 | ;; ball behaves strangely 102 | (setf (pos-vx *ball*) 103 | (- (* (pos-vx *ball*) (/ fx f))) 104 | (pos-x *ball*) 105 | (if (< (pos-x *ball*) 0.5) 106 | (+ (pos-x p) *ball-width*) 107 | (- (pos-x p) *ball-width*)) 108 | 109 | (pos-vy *ball*) 110 | (+ (pos-vy *ball*) 111 | (* (cond 112 | ((> (pos-y p) 0.6) -1) 113 | ((< (pos-y p) 0.4) -1) 114 | (t 1)) 115 | (/ fy f) 116 | (sqrt (+ (* (pos-vx *ball*) (pos-vx *ball*)) 117 | (* (pos-vy *ball*) (pos-vy *ball*)))))))))) 118 | 119 | (when (or (> (pos-x *ball*) *log-x*) 120 | (< (pos-x *ball*) 0) 121 | (> (pos-y *ball*) *log-y*) 122 | (< (pos-y *ball*) 0)) 123 | (reset-game)))) 124 | 125 | 126 | 127 | (defun pong-create (hwnd) 128 | ;; initialize the client area ... we don't have any extra controls just yet 129 | ;; we could add a static for player scores ... but not done that yet 130 | 131 | ;; set the timer to start ticking 132 | (set-timer :hwnd hwnd :elapse 1 :replace-timer 1) 133 | 134 | nil) 135 | 136 | (defun pong-paint (hwnd) 137 | ;; repaint the client area 138 | (with-paint (hwnd hdc) 139 | ;; paint rectangles, line and ball 140 | (let* ((black (get-stock-object :black-brush)) 141 | (white (get-stock-object :white-brush)) 142 | (hold-brush (select-object hdc black))) 143 | (select-object hdc white) 144 | 145 | (let ((p (pos-physical *p1*))) 146 | (rectangle hdc (pos-x p) (pos-y p) 147 | (+ (pos-x p) *pad-width-phys*) 148 | (+ (pos-y p) *pad-height-phys*))) 149 | (let ((p (pos-physical *p2*))) 150 | (rectangle hdc (pos-x p) (pos-y p) 151 | (+ (pos-x p) *pad-width-phys*) 152 | (+ (pos-y p) *pad-height-phys*))) 153 | 154 | (let* ((pen (get-stock-object :white-pen)) 155 | (hold-pen (select-object hdc pen))) 156 | (move-to hdc (truncate *phys-x* 2) 0) 157 | (line-to hdc (truncate *phys-x* 2) *phys-y*) 158 | 159 | (move-to hdc 0 0) 160 | (line-to hdc *phys-x* 0) 161 | (line-to hdc *phys-x* *phys-y*) 162 | (line-to hdc 0 *phys-y*) 163 | (line-to hdc 0 0) 164 | 165 | (select-object hdc hold-pen)) 166 | 167 | (let ((p (pos-physical *ball*))) 168 | (ellipse hdc (pos-x p) (pos-y p) 169 | (+ (pos-x p) *ball-width-phys*) 170 | (+ (pos-y p) *ball-width-phys*))) 171 | 172 | (select-object hdc hold-brush)))) 173 | 174 | (defun pong-timer (hwnd) 175 | (update-game) 176 | (invalidate-rect hwnd nil t)) 177 | 178 | (defun pong-keydown (hwnd wparam) 179 | (let ((key (virtual-code-key wparam))) 180 | (case key 181 | (:up (setf (pos-vy *p1*) -0.005)) 182 | (:down (setf (pos-vy *p1*) 0.005)) 183 | (:keyr ;; reset game 184 | (reset-game)) 185 | (:keyq ;; quit 186 | (destroy-window hwnd)) 187 | (:keyh ;; help 188 | (message-box :hwnd hwnd 189 | :text " 190 | Simple pong game. 191 | Up/down move paddle 192 | R reset game 193 | Q quit 194 | " 195 | :caption "Help" 196 | :icon :information))))) 197 | 198 | (defwndproc pong-wndproc (hwnd msg wparam lparam) 199 | (switch msg 200 | ((const +wm-create+) 201 | (pong-create hwnd)) 202 | ((const +wm-paint+) 203 | (pong-paint hwnd)) 204 | ((const +wm-timer+) 205 | (pong-timer hwnd)) 206 | ((const +wm-keydown+) 207 | (pong-keydown hwnd wparam)) 208 | ((const +wm-destroy+) 209 | (post-quit-message))) 210 | (default-window-proc hwnd msg wparam lparam)) 211 | 212 | 213 | 214 | (defun pong () 215 | (register-class "PONG" (callback pong-wndproc) 216 | :cursor (load-cursor :arrow) 217 | :background (get-stock-object :black-brush)) 218 | (let ((hwnd (create-window "PONG" 219 | :window-name "Pong" 220 | :styles (logior-consts +ws-overlappedwindow+ +ws-visible+) 221 | :x 100 :y 100 :width 400 :height 300)) 222 | (msg (make-msg))) 223 | (show-window hwnd) 224 | (update-window hwnd) 225 | (do ((done nil)) 226 | (done) 227 | (let ((r (get-message msg))) 228 | (cond 229 | ((zerop r) (setf done t)) 230 | (t 231 | (translate-message msg) 232 | (dispatch-message msg))))))) 233 | -------------------------------------------------------------------------------- /examples/printer/printer.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; This file shows how to print files using the print spooler 5 | 6 | (defpackage #:ftw.printer 7 | (:use #:cl #:ftw) 8 | (:export #:print-file 9 | #:print-data)) 10 | 11 | (in-package #:ftw.printer) 12 | 13 | (defvar *hook* nil) 14 | 15 | (defwndproc print-wndproc (hwnd msg wparam lparam) 16 | (switch msg 17 | (ftw::+wm-create+ 18 | (create-window :button 19 | :x 100 :y 100 :width 100 :height 100 20 | :window-name "Print" 21 | :menu 1 22 | :styles (logior ftw::+ws-child+ ftw::+ws-visible+) 23 | :parent hwnd)) 24 | (ftw::+wm-destroy+ 25 | (post-quit-message)) 26 | (ftw::+wm-command+ 27 | (when *hook* 28 | (funcall *hook* (getf (print-dialog hwnd) :device))))) 29 | (default-window-proc hwnd msg wparam lparam)) 30 | 31 | (defun print-main () 32 | (default-message-loop 'print-wndproc 33 | :class-name "FTW_PRINTER" 34 | :title "Printer")) 35 | 36 | ;; ;; These use the print spooler APIs 37 | ;; (defun print-data (data) 38 | ;; (let* ((printinfo (print-dialog))) 39 | ;; (when printinfo 40 | ;; (let ((hp (open-printer (getf printinfo :device)))) 41 | ;; (unwind-protect 42 | ;; (progn 43 | ;; (start-doc-printer hp 44 | ;; :name "My Document" 45 | ;; :datatype "RAW") ;; "NT EMF 1.008" 46 | ;; (start-page-printer hp) 47 | ;; (write-printer hp data) 48 | ;; (end-page-printer hp) 49 | ;; (end-doc-printer hp)) 50 | ;; (close-printer hp)))))) 51 | 52 | 53 | 54 | ;; (defun print-file () 55 | ;; (let ((filenames (nth-value 1 (get-open-file-name :title "Print file")))) 56 | ;; (when filenames 57 | ;; (with-open-file (f (first filenames) :direction :input :element-type '(unsigned-byte 8)) 58 | ;; (let ((data (make-array (file-length f) :element-type '(unsigned-byte 8)))) 59 | ;; (read-sequence data f) 60 | ;; (print-data data)))))) 61 | 62 | 63 | ;; -------------------- 64 | 65 | ;; these use the GDI APIs 66 | 67 | (defun print-rectangle () 68 | (flet ((hook (device-name) 69 | (when device-name 70 | (let ((hdc (create-dc device-name))) 71 | (unwind-protect 72 | (progn 73 | (start-doc hdc "Print file") 74 | (start-page hdc) 75 | (select-object hdc (get-stock-object :black-brush)) 76 | (rectangle hdc 100 100 250 250) 77 | (end-page hdc) 78 | (end-doc hdc)) 79 | (delete-dc hdc)))))) 80 | (setf *hook* #'hook) 81 | (print-main))) 82 | 83 | ;; this uses the with-printer-dc macro 84 | (defun print-rectangles () 85 | "Print a solid black rectangle with a white rectangle inside it." 86 | (let ((device-name (getf (print-dialog) :device))) 87 | (when device-name 88 | (with-printer-dc (hdc device-name) 89 | (select-object hdc (get-stock-object :black-brush)) 90 | (print-page 91 | (rectangle hdc 200 200 300 300) 92 | (select-object hdc (get-stock-object :white-brush)) 93 | (rectangle hdc 250 250 275 275)))))) 94 | -------------------------------------------------------------------------------- /examples/rpc/rpc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; RPC client. Requires frpc2 available from http://github.com/fjames86/frpc2. 5 | 6 | (defpackage #:ftw.rpc 7 | (:use #:cl #:ftw) 8 | (:export #:rpc)) 9 | 10 | (in-package #:ftw.rpc) 11 | 12 | (defparameter *clt* 13 | (make-instance 'frpc2:udp-client :timeout 0)) 14 | 15 | (defun rpc-create (hwnd) 16 | (create-button "Discover" :parent hwnd 17 | :x 25 :y 25 :width 75 :height 23) 18 | (let ((h (create-window :listbox 19 | :ex-styles ftw::+ws-ex-clientedge+ 20 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+) 21 | :x 25 :y 50 :width 200 :height 200 22 | :parent hwnd 23 | :menu 1))) 24 | (set-default-font h) 25 | (register-hwnd 'ip-lb h 1)) 26 | nil) 27 | 28 | (defun rpc-command (hwnd id) 29 | (declare (ignore hwnd id)) 30 | (send-message (hwnd-by-name 'ip-lb) ftw::+lb-resetcontent+ 0 0) 31 | (frpc2:send-rpc *clt* #'drx:encode-void nil #'drx:decode-void 32 | 100000 2 0)) 33 | 34 | (defun rpc-event-cb (clt) 35 | (frpc2:recv-rpc clt) 36 | (with-wide-string (ws (fsocket:sockaddr-string (frpc2:udp-client-addr clt))) 37 | (send-message (hwnd-by-name 'ip-lb) ftw::+lb-addstring+ 0 ws))) 38 | 39 | (defwndproc rpc-wndproc (hwnd msg wparam lparam) 40 | (switch msg 41 | (ftw::+wm-create+ 42 | (rpc-create hwnd)) 43 | (ftw::+wm-command+ 44 | (rpc-command hwnd (loword wparam))) 45 | (ftw::+wm-close+ 46 | (post-quit-message))) 47 | (default-window-proc hwnd msg wparam lparam)) 48 | 49 | (defun rpc () 50 | (default-message-loop-multiple 'rpc-wndproc 51 | :class-name "FTW_RPC" 52 | :title "RPC Client" 53 | :handle-procs (list (list (fsocket::poll-context-event (frpc2::udp-client-pc *clt*)) 54 | #'rpc-event-cb 55 | *clt*)))) 56 | 57 | 58 | -------------------------------------------------------------------------------- /examples/scrollbar/scrollbar.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:ftw.scrollbar 3 | (:use #:cl #:ftw)) 4 | 5 | (in-package #:ftw.scrollbar) 6 | 7 | (defparameter *xclient* 0) 8 | (defparameter *yclient* 0) 9 | (defparameter *xclientmax* 0) 10 | (defparameter *xchar* 0) 11 | (defparameter *ychar* 0) 12 | (defparameter *xupper* 0) 13 | (defparameter *xpos* 0) 14 | (defparameter *ypos* 0) 15 | 16 | (defparameter *lines* 17 | '( 18 | "anteater" "bear" "cougar" 19 | "dingo" "elephant" "falcon" 20 | "gazelle" "hyena" "iguana" 21 | "jackal" "kangaroo" "llama" 22 | "moose" "newt" "octopus" 23 | "penguin" "quail" "rat" 24 | "squid" "tortoise" "urus" 25 | "vole" "walrus" "xylophone" 26 | "yak" "zebra" 27 | "This line contains words, but no character. Go figure." 28 | "")) 29 | 30 | (defwndproc scrollbar-wndproc (hwnd msg wparam lparam) 31 | (switch msg 32 | (ftw::+wm-create+ 33 | (with-dc (hdc hwnd) 34 | (let ((tm (get-text-metrics hdc))) 35 | (setf *xchar* (getf tm :avcharwidth) 36 | *xupper* (truncate (* (if (zerop (logand (getf tm :pitch-and-family) #x1)) 37 | 2 38 | 3) 39 | *xchar*) 40 | 2) 41 | *ychar* (+ (getf tm :height) (getf tm :external-leading))))) 42 | (setf *xclientmax* (+ (* 48 *xchar*) (* 12 *xupper*)))) 43 | (ftw::+wm-destroy+ 44 | (post-quit-message)) 45 | (ftw::+wm-size+ 46 | (let ((yclient (hiword lparam)) 47 | (xclient (loword lparam))) 48 | (set-scroll-info hwnd :vert 49 | :min 0 :max (1- (length *lines*)) 50 | :page (truncate yclient *ychar*) 51 | :redraw t) 52 | (set-scroll-info hwnd :horz 53 | :min 0 :max (+ 2 (truncate *xclientmax* *xchar*)) 54 | :page (truncate xclient *xchar*) 55 | :redraw t))) 56 | (ftw::+wm-hscroll+ 57 | (let ((si (get-scroll-info hwnd :horz))) 58 | (let ((xpos (getf si :pos))) 59 | (switch (loword wparam) 60 | (ftw::+sb-lineleft+ 61 | (decf (getf si :pos))) 62 | (ftw::+sb-lineright+ 63 | (incf (getf si :pos))) 64 | (ftw::+sb-pageleft+ 65 | (decf (getf si :pos) (getf si :page))) 66 | (ftw::+sb-pageright+ 67 | (incf (getf si :pos) (getf si :page))) 68 | (ftw::+sb-thumbtrack+ 69 | (setf (getf si :pos) (getf si :trackpos)))) 70 | (set-scroll-info hwnd :horz :pos (getf si :pos)) 71 | (setf si (get-scroll-info hwnd :horz)) 72 | (unless (= xpos (getf si :pos)) 73 | (scroll-window-ex hwnd 74 | (* *xchar* (- xpos (getf si :pos))) 75 | 0 76 | :flags '(:erase :invalidate)))))) 77 | (ftw::+wm-vscroll+ 78 | (let ((si (get-scroll-info hwnd :vert))) 79 | (let ((ypos (getf si :pos))) 80 | (switch (loword wparam) 81 | (ftw::+sb-top+ 82 | (setf (getf si :pos) (getf si :min))) 83 | (ftw::+sb-bottom+ 84 | (setf (getf si :pos) (getf si :max))) 85 | (ftw::+sb-lineup+ 86 | (decf (getf si :pos))) 87 | (ftw::+sb-linedown+ 88 | (incf (getf si :pos))) 89 | (ftw::+sb-pageup+ 90 | (decf (getf si :pos) (getf si :page))) 91 | (ftw::+sb-pagedown+ 92 | (incf (getf si :pos) (getf si :page))) 93 | (ftw::+sb-thumbtrack+ 94 | (setf (getf si :pos) (getf si :trackpos)))) 95 | (set-scroll-info hwnd :vert :pos (getf si :pos)) 96 | (setf si (get-scroll-info hwnd :vert)) 97 | (unless (= ypos (getf si :pos)) 98 | (scroll-window-ex hwnd 99 | 0 100 | (* *ychar* (- ypos (getf si :pos))) 101 | :flags '(:erase :invalidate)))))) 102 | (ftw::+wm-paint+ 103 | (with-paint (hwnd hdc ps) 104 | (let (xpos ypos firstline lastline) 105 | (let ((si (get-scroll-info hwnd :horz))) 106 | (setf xpos (getf si :pos))) 107 | (let ((si (get-scroll-info hwnd :vert))) 108 | (setf ypos (getf si :pos))) 109 | (setf firstline (max 0 (+ ypos (truncate (rect-top (paintstruct-paint ps)) *ychar*))) 110 | lastline (min (1- (length *lines*)) (+ ypos (truncate (rect-bottom (paintstruct-paint ps)) *ychar*)))) 111 | 112 | (do ((i firstline (1+ i))) 113 | ((> i lastline)) 114 | (let ((x (* *xchar* (- 1 xpos))) 115 | (y (* *ychar* (- i ypos)))) 116 | (text-out hdc (nth i *lines*) x y))))))) 117 | (default-window-proc hwnd msg wparam lparam)) 118 | 119 | (defun scrollbar () 120 | (default-message-loop 'scrollbar-wndproc 121 | :class-name "FTW_SCROLLBAR" 122 | :title "Scrollbar" 123 | :width 300 :height 400)) 124 | 125 | 126 | -------------------------------------------------------------------------------- /examples/tetris/tetris.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;;; Little tetris game. 4 | 5 | (defpackage #:ftw.tetris 6 | (:use #:cl #:ftw) 7 | (:export #:tetris)) 8 | 9 | (in-package #:ftw.tetris) 10 | 11 | ;; ------------------- Game logic ----------------- 12 | 13 | (defstruct shape 14 | x y 15 | points 16 | color) 17 | 18 | (defun shape-cells (s) 19 | (mapcar (lambda (p) 20 | (destructuring-bind (x y) p 21 | (list (+ x (shape-x s)) 22 | (+ y (shape-y s))))) 23 | (shape-points s))) 24 | 25 | (defvar *random-color* nil) 26 | (defparameter *width* 12) 27 | (defparameter *height* 28) 28 | (defparameter *tetris* nil) 29 | 30 | (defun random-shape () 31 | (let ((s (random 6))) 32 | (make-shape 33 | :x (truncate *width* 2) :y (- *height* 2) 34 | :points 35 | (switch s 36 | (0 ;; box 37 | (list (list 0 0) (list 0 1) (list 1 0) (list 1 1))) 38 | (1 ;; left-L 39 | (list (list 0 0) (list 1 0) (list 1 1) (list 1 2))) 40 | (2 ;; right-L 41 | (list (list 0 0) (list 1 0) (list 0 1) (list 0 2))) 42 | (3 ;; long 43 | (list (list 0 0) (list 0 1) (list 0 2) (list 0 3))) 44 | (4 ;; s 45 | (list (list 0 0) (list 1 0) (list 1 1) (list 2 1))) 46 | (5 ;; z 47 | (list (list 0 1) (list 1 1) (list 1 0) (list 2 0)))) 48 | :color 49 | (switch (if *random-color* s (random 6)) 50 | (0 (encode-rgb 255 0 0)) 51 | (1 (encode-rgb 0 255 0)) 52 | (2 (encode-rgb 0 0 255)) 53 | (3 (encode-rgb 0 127 127)) 54 | (4 (encode-rgb 127 0 127)) 55 | (5 (encode-rgb 127 127 0)))))) 56 | 57 | 58 | (defun collision-p (s) 59 | (dolist (p (shape-points s)) 60 | (destructuring-bind (x y) p 61 | (when (cell (+ (shape-x s) x) 62 | (+ (shape-y s) y)) 63 | (return-from collision-p t)))) 64 | nil) 65 | 66 | (defun adjust-shape-pos (s) 67 | "Ensure no y coord is negative" 68 | (let ((min-y (apply #'min (mapcar #'second (shape-points s))))) 69 | (when (< min-y 0) 70 | (dolist (p (shape-points s)) 71 | (incf (second p) (- min-y))))) 72 | (let ((min-x (apply #'min (mapcar #'first (shape-points s))))) 73 | (when (< min-x 0) 74 | (dolist (p (shape-points s)) 75 | (incf (first p) (- min-x)))))) 76 | 77 | (defun rotate-shape-r (s) 78 | (mapc (lambda (p) 79 | ;; x' = y , y' = -x 80 | (let ((x (first p)) 81 | (y (second p))) 82 | (setf (first p) y 83 | (second p) (- x)))) 84 | (shape-points s)) 85 | (adjust-shape-pos s)) 86 | 87 | (defun rotate-shape-l (s) 88 | (mapc (lambda (p) 89 | ;; x' = -y , y' = x 90 | (let ((x (first p)) 91 | (y (second p))) 92 | (setf (first p) (- y) 93 | (second p) x))) 94 | (shape-points s)) 95 | (adjust-shape-pos s)) 96 | 97 | (defun shift-shape-l (s) 98 | (when (> (shape-x s) 0) 99 | (decf (shape-x s)) 100 | (when (collision-p s) 101 | (incf (shape-x s))))) 102 | 103 | (defun shift-shape-r (s) 104 | (let ((max-x (apply #'max (mapcar #'first (shape-points s))))) 105 | (when (< (+ (shape-x s) max-x) (1- *width*)) 106 | (incf (shape-x s)) 107 | (when (collision-p s) 108 | (decf (shape-x s)))))) 109 | 110 | (defstruct tetris 111 | cells 112 | shape 113 | next 114 | speed 115 | level 116 | next-level 117 | score) 118 | 119 | (defun new-game () 120 | (setf *tetris* 121 | (make-tetris 122 | :cells (make-array (list *width* *height*) 123 | :initial-element nil) 124 | :shape (random-shape) 125 | :next (random-shape) 126 | :speed 250 127 | :level 1 128 | :next-level 10 129 | :score 0))) 130 | (defun cell (x y) 131 | (when (and (>= x 0) (< x *width*) 132 | (>= y 0) (< y *height*)) 133 | (aref (tetris-cells *tetris*) x y))) 134 | (defun (setf cell) (value x y) 135 | (setf (aref (tetris-cells *tetris*) x y) value)) 136 | 137 | (defun shift-lines (row) 138 | (do ((y row (1+ y))) 139 | ((= y (1- *height*))) 140 | (do ((x 0 (1+ x))) 141 | ((= x *width*)) 142 | (setf (cell x y) 143 | (if (= y (1- *height*)) 144 | nil 145 | (cell x (1+ y))))))) 146 | 147 | (defun shift-shape-down () 148 | (let ((s (tetris-shape *tetris*))) 149 | (cond 150 | ((some (lambda (p) 151 | (destructuring-bind (x y) p 152 | ;; collision if bottom row or something in the row below 153 | (or (zerop y) 154 | (cell x (1- y))))) 155 | (shape-cells s)) 156 | (mapc (lambda (p) 157 | (destructuring-bind (x y) p 158 | (setf (cell x y) (shape-color s)))) 159 | (shape-cells s)) 160 | (setf (tetris-shape *tetris*) 161 | (tetris-next *tetris*) 162 | (tetris-next *tetris*) 163 | (random-shape))) 164 | (t 165 | (decf (shape-y s)))))) 166 | 167 | (defun update-game (hwnd) 168 | ;; 1. if the piece would collide with a filled cell then 169 | ;; we copy the piece into the cells, assign the next shapre 170 | ;; to the current shape and generate a new next shape 171 | (let ((s (tetris-shape *tetris*))) 172 | 173 | (shift-shape-down) 174 | 175 | ;; 2. if filling in the cells also completes a line, 176 | ;; then clear the cells, move all cells above downwards and 177 | ;; keep repeating that until no lines are complete. 178 | ;; 3. for each completed line, increment the score by width*level. 179 | (do ((i (- (shape-y s) 2))) 180 | ((= i (+ (shape-y s) 3))) 181 | (cond 182 | ((do ((j 0 (1+ j)) 183 | (complete t)) 184 | ((or (not complete) (= j *width*)) complete) 185 | (unless (cell j i) (setf complete nil))) 186 | ;; line complete -- move everything downwards 187 | (shift-lines i) 188 | (incf (tetris-score *tetris*) (* (tetris-level *tetris*) *width*)) 189 | 190 | ;; 4. if line complete, decrement the next-level counter. 191 | ;; if that reaches zero then increment the level, 192 | ;; decrement the speed and reset the next-level counter. 193 | (decf (tetris-next-level *tetris*)) 194 | (when (zerop (tetris-next-level *tetris*)) 195 | (incf (tetris-level *tetris*)) 196 | (setf (tetris-speed *tetris*) 197 | (max 15 (- (tetris-speed *tetris*) 50)) 198 | (tetris-next-level *tetris*) 199 | 10) 200 | (set-timer :hwnd hwnd 201 | :elapse (tetris-speed *tetris*) 202 | :replace-timer 1))) 203 | (t 204 | ;; line incomplete -- increment row counter 205 | (incf i))))) 206 | 207 | *tetris*) 208 | 209 | 210 | ;; --------------- GUI ------------------- 211 | 212 | (defvar *paused* nil) 213 | (defparameter *w* 15) 214 | 215 | (defun tetris-paint (hwnd) 216 | 217 | (with-paint (hwnd hdc) 218 | 219 | (draw-edge hdc 220 | (make-rect :left 49 221 | :right (+ 50 (* *w* *width*)) 222 | :top 50 223 | :bottom (+ 100 (* *w* *height*))) 224 | :inner-edge :sunk 225 | :outer-edge :raised 226 | :flags '(:left :top :right :bottom :adjust)) 227 | 228 | ;; draw cells 229 | (dotimes (i *width*) 230 | (dotimes (j *height*) 231 | (let ((c (cell i j))) 232 | (when c 233 | (let* ((brush (create-solid-brush c)) 234 | (hold-brush (select-object hdc brush))) 235 | (rectangle hdc 236 | (+ 50 (* i *w*)) (+ 85 (* (- *height* j) *w*)) 237 | (+ 50 *w* (* i *w*)) (+ 85 *w* (* (- *height* j) *w*))) 238 | (select-object hdc hold-brush) 239 | (delete-object brush)))))) 240 | 241 | ;; draw shape 242 | (dolist (p (shape-cells (tetris-shape *tetris*))) 243 | (destructuring-bind (i j) p 244 | (let* ((brush (create-solid-brush (shape-color (tetris-shape *tetris*)))) 245 | (hold-brush (select-object hdc brush))) 246 | (rectangle hdc 247 | (+ 50 (* i *w*)) (+ 85 (* (- *height* j) *w*)) 248 | (+ 50 *w* (* i *w*)) (+ 85 *w* (* (- *height* j) *w*))) 249 | (select-object hdc hold-brush) 250 | (delete-object brush)))) 251 | 252 | 253 | ;; print score 254 | (draw-edge hdc 255 | (make-rect :left (+ 100 (* *w* *width*)) 256 | :top 50 257 | :right (+ 180 (* *w* *width*)) 258 | :bottom 120) 259 | :flags '(:left :top :right :bottom)) 260 | (text-out hdc 261 | (format nil "Score: ~A" (tetris-score *tetris*)) 262 | (+ 100 *w* (* *w* *width*)) 263 | 65) 264 | (text-out hdc 265 | (format nil "Level: ~A" (tetris-level *tetris*)) 266 | (+ 100 *w* (* *w* *width*)) 267 | 85) 268 | 269 | ;; show next shape 270 | (let* ((brush (create-solid-brush (shape-color (tetris-next *tetris*)))) 271 | (hold-brush (select-object hdc brush))) 272 | (dolist (p (shape-points (tetris-next *tetris*))) 273 | (destructuring-bind (i j) p 274 | (rectangle hdc 275 | (+ 100 (* *width* *w*) (* i *w*)) 276 | (+ 200 (* j *w*)) 277 | (+ 100 *w* (* *width* *w*) (* i *w*)) 278 | (+ 200 *w* (* j *w*))))) 279 | 280 | (select-object hdc hold-brush) 281 | (delete-object brush)))) 282 | 283 | 284 | (defun tetris-keydown (hwnd wparam) 285 | (let ((key (virtual-code-key wparam))) 286 | (case key 287 | (:left 288 | (shift-shape-l (tetris-shape *tetris*))) 289 | (:right 290 | (shift-shape-r (tetris-shape *tetris*))) 291 | (:up 292 | (rotate-shape-r (tetris-shape *tetris*))) 293 | (:down 294 | (update-game hwnd)) 295 | (:keyq 296 | (destroy-window hwnd)) 297 | (:keyn 298 | (new-game)) 299 | (:keyp (setf *paused* t)))) 300 | (invalidate-rect hwnd nil t)) 301 | 302 | 303 | (defwndproc tetris-wndproc (hwnd msg wparam lparam) 304 | (switch msg 305 | ((const +wm-create+) 306 | ;; new game 307 | (new-game) 308 | 309 | ;; set update timer 310 | (set-timer :hwnd hwnd :elapse (tetris-speed *tetris*) :replace-timer 1)) 311 | ((const +wm-destroy+) 312 | (post-quit-message)) 313 | ((const +wm-paint+) 314 | (tetris-paint hwnd)) 315 | ((const +wm-keydown+) 316 | (tetris-keydown hwnd wparam)) 317 | ((const +wm-timer+) 318 | (update-game hwnd) 319 | (invalidate-rect hwnd nil t))) 320 | 321 | (default-window-proc hwnd msg wparam lparam)) 322 | 323 | (defun tetris () 324 | (default-message-loop (cffi:callback tetris-wndproc) 325 | :class-name "FTW_TETRIS" 326 | :title "Tetris" 327 | :width 400 :height (* *w* (+ *height* 12)))) 328 | 329 | 330 | -------------------------------------------------------------------------------- /examples/treeview/treeview.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:ftw.treeview 3 | (:use #:cl #:ftw) 4 | (:export #:treeview)) 5 | 6 | (in-package #:ftw.treeview) 7 | 8 | (defvar *TEST2-BITMAP* 9 | (create-bitmap-resource 32 32 1 32 10 | #( #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 11 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 12 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 13 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 14 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 15 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 16 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 17 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 18 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 19 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 20 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 21 | #x00 #x01 #x00 #x02 #x00 #x02 #x00 #x03 #x01 #x03 #x00 #x05 #x00 #x02 #x00 #x04 22 | #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 23 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 24 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 25 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 26 | 27 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 28 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 29 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x01 #x05 #x01 #x08 30 | #x04 #x0E #x03 #x15 #x08 #x1A #x06 #x25 #x0A #x1E #x08 #x2B #x09 #x1B #x07 #x27 31 | #x06 #x14 #x05 #x1D #x03 #x0B #x03 #x10 #x01 #x04 #x01 #x06 #x00 #x00 #x00 #x01 32 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 33 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 34 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 35 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 36 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 37 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x02 #x07 #x03 #x0C #x09 #x1D #x09 #x2B 38 | #x12 #x38 #x0F #x51 #x18 #x4B #x13 #x6A #x1B #x51 #x15 #x73 #x1A #x50 #x15 #x72 39 | #x18 #x49 #x13 #x67 #x13 #x3B #x0F #x54 #x0C #x27 #x0A #x37 #x06 #x14 #x05 #x1D 40 | #x02 #x06 #x01 #x09 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 41 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 42 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 43 | 44 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 45 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 46 | #x00 #x00 #x03 #x04 #x01 #x03 #x0C #x12 #x07 #x16 #x15 #x31 #x14 #x3D #x1C #x65 47 | #x1D #x58 #x1E #x85 #x1F #x5E #x1C #x8A #x1F #x5E #x19 #x87 #x1F #x5F #x19 #x86 48 | #x1F #x5F #x19 #x86 #x1F #x5D #x18 #x84 #x1D #x58 #x17 #x7C #x17 #x47 #x13 #x65 49 | #x0F #x2E #x0C #x41 #x06 #x13 #x05 #x1C #x02 #x07 #x02 #x0B #x00 #x00 #x01 #x03 50 | #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 51 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 52 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 53 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x06 #x07 54 | #x00 #x00 #x1A #x1E #x03 #x08 #x33 #x42 #x0E #x2C #x41 #x7A #x1C #x55 #x3F #xA6 55 | #x1F #x5F #x3A #xAB #x1F #x5F #x30 #xA1 #x1F #x5F #x24 #x94 #x1F #x5F #x1D #x8C 56 | #x1F #x5F #x1A #x89 #x1F #x5F #x1A #x88 #x1F #x5F #x19 #x86 #x1F #x5E #x19 #x85 57 | #x1C #x56 #x16 #x7A #x14 #x3F #x13 #x5C #x09 #x1D #x0E #x32 #x02 #x06 #x0E #x17 58 | #x00 #x00 #x0E #x10 #x00 #x00 #x09 #x0B #x00 #x00 #x03 #x04 #x00 #x00 #x00 #x00 59 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 60 | 61 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 62 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x04 #x00 #x00 #x16 #x19 63 | #x01 #x02 #x40 #x49 #x05 #x0E #x61 #x7C #x13 #x38 #x5F #xA9 #x1F #x5D #x54 #xC6 64 | #x20 #x5F #x55 #xCA #x20 #x60 #x54 #xC9 #x20 #x5F #x4B #xBF #x1F #x5F #x3B #xAD 65 | #x1F #x60 #x2A #x9A #x1F #x5F #x22 #x91 #x1F #x5F #x1C #x8B #x1F #x5F #x19 #x87 66 | #x1F #x5E #x19 #x87 #x1C #x58 #x1E #x84 #x12 #x36 #x26 #x68 #x05 #x0E #x34 #x4A 67 | #x01 #x02 #x37 #x40 #x00 #x00 #x29 #x2E #x00 #x00 #x14 #x17 #x00 #x00 #x04 #x05 68 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 69 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 70 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x07 #x08 #x00 #x00 #x27 #x2C 71 | #x01 #x02 #x5C #x69 #x05 #x0E #x71 #x8E #x14 #x3C #x64 #xB2 #x1F #x5D #x5C #xCF 72 | #x20 #x60 #x62 #xD9 #x20 #x60 #x68 #xDF #x20 #x60 #x68 #xDF #x20 #x60 #x61 #xD8 73 | #x1F #x60 #x4D #xC1 #x20 #x60 #x38 #xAA #x1F #x60 #x29 #x99 #x1F #x5F #x1E #x8D 74 | #x1F #x5F #x1B #x8A #x1E #x5E #x27 #x95 #x17 #x47 #x3D #x94 #x08 #x17 #x5D #x81 75 | #x01 #x03 #x66 #x75 #x01 #x01 #x54 #x5E #x00 #x00 #x31 #x37 #x00 #x00 #x0F #x11 76 | #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 77 | 78 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 79 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x0A #x0C #x00 #x00 #x31 #x37 80 | #x01 #x01 #x68 #x75 #x04 #x0A #x79 #x92 #x0F #x2C #x74 #xB3 #x1D #x57 #x6A #xD8 81 | #x20 #x60 #x6C #xE3 #x20 #x60 #x6C #xE4 #x20 #x60 #x6C #xE4 #x20 #x60 #x6C #xE4 82 | #x20 #x60 #x64 #xDB #x1F #x60 #x51 #xC6 #x1F #x60 #x3D #xAF #x1F #x60 #x29 #x99 83 | #x1F #x5F #x21 #x90 #x1E #x5D #x2E #x9D #x17 #x46 #x4D #xA4 #x08 #x16 #x6D #x92 84 | #x02 #x03 #x75 #x86 #x01 #x01 #x6F #x7C #x01 #x01 #x4F #x58 #x00 #x00 #x1C #x20 85 | #x00 #x00 #x03 #x04 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 86 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 87 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x06 #x07 #x00 #x00 #x28 #x2D 88 | #x01 #x01 #x63 #x6F #x02 #x04 #x87 #x9B #x09 #x19 #x92 #xBF #x16 #x40 #x82 #xD9 89 | #x1F #x5B #x70 #xE3 #x20 #x5F #x6D #xE4 #x20 #x60 #x6D #xE5 #x20 #x60 #x6C #xE4 90 | #x20 #x60 #x6C #xE4 #x20 #x5F #x62 #xD8 #x20 #x60 #x4F #xC4 #x1F #x5F #x3A #xAC 91 | #x1F #x5F #x27 #x96 #x1D #x5A #x34 #x9F #x14 #x3B #x55 #xA1 #x06 #x12 #x6F #x90 92 | #x01 #x02 #x77 #x86 #x01 #x01 #x76 #x84 #x01 #x01 #x5D #x68 #x00 #x00 #x25 #x2A 93 | #x00 #x00 #x06 #x07 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 94 | 95 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 96 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x04 #x00 #x00 #x18 #x1B 97 | #x01 #x01 #x4E #x57 #x01 #x01 #x8F #xA0 #x03 #x06 #xAA #xC3 #x0A #x1D #x9D #xCF 98 | #x14 #x3B #x88 #xD9 #x1B #x50 #x78 #xE0 #x1E #x57 #x73 #xE2 #x1E #x59 #x71 #xE3 99 | #x1F #x5B #x70 #xE2 #x1F #x5D #x6D #xE2 #x1F #x5D #x60 #xD4 #x1F #x5E #x48 #xBA 100 | #x1D #x59 #x31 #x9C #x17 #x45 #x3D #x92 #x0C #x23 #x62 #x94 #x03 #x09 #x74 #x8B 101 | #x01 #x02 #x78 #x87 #x01 #x01 #x76 #x84 #x01 #x01 #x5E #x69 #x00 #x00 #x24 #x29 102 | #x00 #x00 #x05 #x06 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 103 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 104 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x08 #x09 105 | #x00 #x00 #x30 #x36 #x01 #x01 #x88 #x98 #x02 #x02 #xB0 #xC5 #x03 #x04 #xB0 #xC8 106 | #x06 #x10 #xA8 #xCC #x0B #x1E #x9D #xD0 #x0E #x28 #x95 #xD3 #x0F #x2D #x91 #xD5 107 | #x10 #x32 #x8E #xD6 #x14 #x3B #x87 #xD9 #x16 #x43 #x7D #xD6 #x16 #x42 #x62 #xB7 108 | #x12 #x38 #x42 #x88 #x0B #x22 #x4F #x7E #x05 #x0E #x6D #x89 #x02 #x03 #x76 #x87 109 | #x01 #x01 #x78 #x86 #x01 #x01 #x73 #x81 #x01 #x01 #x54 #x5E #x00 #x00 #x1C #x20 110 | #x00 #x00 #x03 #x04 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 111 | 112 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 113 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 114 | #x00 #x00 #x16 #x19 #x01 #x01 #x69 #x76 #x02 #x02 #xAD #xC1 #x02 #x02 #xB2 #xC7 115 | #x02 #x03 #xB0 #xC7 #x03 #x0A #xAB #xCA #x06 #x11 #xA5 #xCC #x08 #x18 #xA0 #xCE 116 | #x0A #x1E #x9C #xD0 #x0B #x21 #x9A #xD1 #x0A #x1E #x9C #xCF #x08 #x16 #x88 #xB1 117 | #x06 #x10 #x5A #x76 #x03 #x08 #x62 #x76 #x02 #x04 #x76 #x87 #x01 #x01 #x79 #x87 118 | #x01 #x01 #x78 #x86 #x01 #x01 #x6F #x7C #x00 #x00 #x46 #x4E #x00 #x00 #x11 #x14 119 | #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 120 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 121 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 122 | #x00 #x00 #x09 #x0B #x00 #x00 #x49 #x52 #x02 #x02 #x9D #xAF #x04 #x09 #xAB #xC8 123 | #x08 #x17 #xA2 #xCE #x0F #x2C #x92 #xD4 #x15 #x3C #x85 #xD9 #x18 #x45 #x7F #xDC 124 | #x19 #x48 #x7D #xDD #x16 #x40 #x84 #xDB #x0F #x2E #x8F #xD4 #x08 #x19 #x92 #xBE 125 | #x03 #x09 #x66 #x7C #x01 #x03 #x6B #x7B #x01 #x02 #x77 #x86 #x01 #x01 #x79 #x87 126 | #x01 #x01 #x78 #x86 #x01 #x01 #x69 #x76 #x00 #x00 #x36 #x3D #x00 #x00 #x09 #x0B 127 | #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 128 | 129 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 130 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 131 | #x00 #x00 #x03 #x04 #x00 #x01 #x29 #x2F #x04 #x0B #x7A #x95 #x10 #x2E #x89 #xCC 132 | #x1A #x4B #x7B #xDE #x1F #x5B #x70 #xE2 #x20 #x5E #x6E #xE4 #x20 #x5E #x6D #xE4 133 | #x20 #x5E #x6D #xE4 #x1F #x5D #x6F #xE4 #x1B #x51 #x77 #xDF #x12 #x34 #x84 #xCC 134 | #x0A #x1E #x64 #x91 #x06 #x12 #x68 #x88 #x04 #x0A #x73 #x8B #x02 #x03 #x78 #x88 135 | #x01 #x01 #x77 #x85 #x01 #x01 #x65 #x71 #x00 #x00 #x2C #x31 #x00 #x00 #x05 #x06 136 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 137 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 138 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 139 | #x00 #x01 #x02 #x04 #x03 #x0A #x1B #x2A #x10 #x2F #x51 #x8F #x1D #x55 #x5E #xC8 140 | #x1F #x5F #x69 #xDF #x20 #x60 #x6C #xE4 #x20 #x60 #x6C #xE4 #x20 #x60 #x6D #xE5 141 | #x20 #x60 #x6D #xE5 #x20 #x60 #x6D #xE5 #x20 #x5F #x6C #xE3 #x1D #x57 #x6C #xD9 142 | #x18 #x4A #x58 #xB6 #x14 #x3C #x5C #xAA #x0D #x27 #x68 #xA0 #x06 #x11 #x72 #x91 143 | #x02 #x04 #x75 #x86 #x01 #x01 #x62 #x6E #x00 #x00 #x26 #x2B #x00 #x00 #x03 #x04 144 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 145 | 146 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 147 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x02 148 | #x03 #x0B #x03 #x11 #x0F #x2D #x14 #x4A #x1C #x55 #x37 #x9D #x1F #x5F #x4C #xC0 149 | #x20 #x60 #x57 #xCD #x20 #x60 #x66 #xDD #x20 #x60 #x6C #xE4 #x20 #x60 #x6C #xE4 150 | #x20 #x60 #x6C #xE4 #x20 #x60 #x6C #xE4 #x20 #x60 #x68 #xE0 #x20 #x5F #x5E #xD4 151 | #x1F #x5E #x54 #xC7 #x1E #x5A #x53 #xC2 #x18 #x48 #x5B #xB6 #x0C #x23 #x6A #x9E 152 | #x03 #x08 #x73 #x89 #x01 #x01 #x61 #x6E #x00 #x00 #x25 #x2A #x00 #x00 #x02 #x03 153 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 154 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 155 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x02 #x06 #x01 #x09 156 | #x0B #x21 #x08 #x2F #x19 #x4D #x17 #x71 #x1F #x5E #x26 #x94 #x1F #x60 #x36 #xA8 157 | #x1F #x5F #x45 #xB8 #x1F #x5F #x52 #xC7 #x20 #x60 #x62 #xD9 #x20 #x60 #x69 #xE1 158 | #x20 #x60 #x68 #xE0 #x1F #x60 #x64 #xDC #x20 #x5F #x5D #xD3 #x1F #x60 #x55 #xCB 159 | #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC6 #x1D #x57 #x55 #xC1 #x11 #x32 #x64 #xA8 160 | #x04 #x0D #x71 #x8C #x01 #x02 #x5D #x6A #x00 #x00 #x22 #x26 #x00 #x00 #x03 #x04 161 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 162 | 163 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 164 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x02 #x04 #x0C #x03 #x11 165 | #x12 #x38 #x0E #x4F #x1E #x5B #x18 #x81 #x1F #x5F #x1B #x8A #x1F #x5F #x1F #x8E 166 | #x1F #x5F #x27 #x97 #x1F #x5F #x33 #xA4 #x20 #x5F #x4B #xBF #x20 #x60 #x59 #xCF 167 | #x20 #x60 #x59 #xCF #x20 #x60 #x57 #xCC #x20 #x60 #x54 #xC9 #x1F #x5F #x52 #xC7 168 | #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC6 #x1D #x57 #x55 #xC1 #x11 #x32 #x64 #xA8 169 | #x04 #x0D #x71 #x8C #x01 #x02 #x56 #x62 #x00 #x00 #x1C #x20 #x00 #x00 #x02 #x03 170 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 171 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 172 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x02 #x06 #x14 #x05 #x1D 173 | #x17 #x45 #x12 #x62 #x1F #x5E #x19 #x85 #x1F #x5F #x19 #x87 #x1F #x5F #x1A #x88 174 | #x1F #x5F #x1C #x8B #x1F #x60 #x2C #x9C #x1F #x5F #x45 #xB8 #x1F #x60 #x51 #xC6 175 | #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC7 176 | #x1F #x5F #x52 #xC6 #x1E #x5D #x53 #xC4 #x19 #x49 #x5B #xB7 #x0C #x23 #x69 #x9D 177 | #x03 #x08 #x6D #x82 #x01 #x01 #x4B #x55 #x00 #x00 #x13 #x16 #x00 #x00 #x01 #x02 178 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 179 | 180 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 181 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x03 #x07 #x16 #x05 #x1F 182 | #x18 #x49 #x13 #x67 #x1F #x5E #x19 #x85 #x1F #x5F #x19 #x87 #x1F #x5F #x19 #x87 183 | #x1F #x5F #x1D #x8C #x1F #x60 #x2E #x9F #x1F #x5F #x48 #xBC #x1F #x60 #x51 #xC6 184 | #x1F #x5F #x52 #xC7 #x1F #x5F #x52 #xC7 #x1F #x60 #x51 #xC6 #x1F #x5F #x52 #xC6 185 | #x1E #x5A #x53 #xC2 #x18 #x48 #x5C #xB7 #x0E #x2B #x67 #xA3 #x06 #x10 #x71 #x90 186 | #x01 #x03 #x6F #x7F #x01 #x01 #x4F #x58 #x00 #x00 #x1A #x1E #x00 #x00 #x00 #x01 187 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 188 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 189 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x03 #x07 #x16 #x06 #x20 190 | #x18 #x48 #x13 #x66 #x1F #x5E #x19 #x85 #x1F #x5F #x19 #x87 #x1F #x5F #x19 #x87 191 | #x1F #x5F #x1B #x8A #x1F #x60 #x2B #x9B #x1F #x5F #x45 #xB8 #x1F #x60 #x51 #xC6 192 | #x1F #x5F #x52 #xC6 #x1F #x5F #x52 #xC6 #x1F #x5E #x52 #xC5 #x1C #x54 #x55 #xBE 193 | #x13 #x39 #x61 #xAB #x0A #x1C #x6D #x98 #x04 #x0B #x75 #x8E #x02 #x03 #x76 #x87 194 | #x01 #x01 #x76 #x84 #x01 #x01 #x65 #x71 #x00 #x00 #x32 #x38 #x00 #x00 #x0A #x0C 195 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 196 | 197 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 198 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x02 #x05 #x11 #x04 #x18 199 | #x14 #x3C #x10 #x55 #x1E #x5B #x18 #x81 #x1F #x5F #x19 #x86 #x1F #x5F #x19 #x87 200 | #x1F #x5F #x1A #x89 #x1F #x5F #x24 #x93 #x1F #x5E #x3B #xAB #x1E #x5B #x4E #xBE 201 | #x1D #x58 #x54 #xC1 #x1B #x52 #x57 #xBD #x17 #x43 #x5D #xB4 #x0F #x2C #x66 #xA3 202 | #x06 #x12 #x71 #x92 #x02 #x04 #x76 #x88 #x01 #x02 #x78 #x87 #x01 #x01 #x79 #x87 203 | #x01 #x01 #x78 #x86 #x01 #x01 #x72 #x80 #x00 #x00 #x47 #x50 #x00 #x00 #x11 #x14 204 | #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 205 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 206 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x03 #x09 #x02 #x0D 207 | #x0C #x27 #x0A #x37 #x18 #x49 #x13 #x68 #x1D #x5A #x17 #x7F #x1E #x5C #x18 #x83 208 | #x1E #x5C #x18 #x83 #x1D #x58 #x1B #x82 #x19 #x4C #x2B #x85 #x13 #x38 #x48 #x90 209 | #x0E #x2A #x60 #x9A #x0A #x1E #x6B #x98 #x07 #x14 #x70 #x93 #x04 #x0A #x74 #x8C 210 | #x02 #x03 #x78 #x88 #x01 #x01 #x79 #x87 #x01 #x01 #x79 #x87 #x01 #x01 #x79 #x87 211 | #x01 #x01 #x79 #x87 #x01 #x01 #x76 #x84 #x01 #x01 #x51 #x5B #x00 #x00 #x18 #x1B 212 | #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 213 | 214 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 215 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x04 216 | #x05 #x0F #x04 #x16 #x0B #x23 #x09 #x32 #x12 #x38 #x0E #x4F #x15 #x3F #x10 #x5A 217 | #x14 #x3E #x10 #x58 #x10 #x32 #x0E #x48 #x0A #x1F #x12 #x37 #x05 #x0F #x27 #x3D 218 | #x02 #x04 #x47 #x54 #x01 #x02 #x5F #x6D #x01 #x02 #x6C #x7A #x01 #x02 #x73 #x82 219 | #x01 #x01 #x77 #x85 #x01 #x01 #x78 #x86 #x01 #x01 #x79 #x87 #x01 #x01 #x79 #x87 220 | #x01 #x01 #x78 #x86 #x01 #x01 #x70 #x7D #x00 #x00 #x46 #x4E #x00 #x00 #x11 #x14 221 | #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 222 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 223 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 224 | #x00 #x02 #x00 #x03 #x02 #x07 #x01 #x0A #x04 #x0E #x03 #x15 #x05 #x11 #x04 #x19 225 | #x05 #x11 #x04 #x18 #x03 #x0B #x03 #x10 #x01 #x05 #x01 #x08 #x00 #x01 #x07 #x0A 226 | #x00 #x00 #x15 #x18 #x00 #x00 #x2A #x2F #x00 #x00 #x3F #x47 #x01 #x01 #x56 #x60 227 | #x01 #x01 #x67 #x73 #x01 #x01 #x71 #x7E #x01 #x01 #x73 #x81 #x01 #x01 #x73 #x81 228 | #x01 #x01 #x6D #x7A #x01 #x01 #x55 #x5F #x00 #x00 #x2C #x31 #x00 #x00 #x0A #x0C 229 | #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 230 | 231 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 232 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 233 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x01 #x00 #x02 234 | #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 235 | #x00 #x00 #x00 #x01 #x00 #x00 #x05 #x06 #x00 #x00 #x11 #x13 #x00 #x00 #x22 #x26 236 | #x00 #x00 #x34 #x3B #x00 #x00 #x45 #x4D #x01 #x01 #x4D #x56 #x00 #x00 #x4A #x53 237 | #x00 #x00 #x3D #x45 #x00 #x00 #x24 #x29 #x00 #x00 #x0F #x11 #x00 #x00 #x01 #x02 238 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 239 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 240 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 241 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 242 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 243 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x04 #x05 244 | #x00 #x00 #x0A #x0C #x00 #x00 #x11 #x14 #x00 #x00 #x14 #x17 #x00 #x00 #x14 #x17 245 | #x00 #x00 #x0D #x0F #x00 #x00 #x06 #x07 #x00 #x00 #x01 #x02 #x00 #x00 #x00 #x00 246 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 247 | 248 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 249 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 250 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 251 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 252 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 253 | #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x01 #x02 #x00 #x00 #x01 #x02 254 | #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 255 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 256 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 257 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 258 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 259 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 260 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 261 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 262 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 263 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 264 | 265 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 266 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 267 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 268 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 269 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 270 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 271 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 272 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 273 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 274 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 275 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 276 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 277 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 278 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 279 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 280 | #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ))) 281 | 282 | 283 | (defun treeview-create (hwnd) 284 | 285 | (init-common-controls) 286 | 287 | (let ((h (create-window ftw::+wc-treeview+ 288 | :window-name "fred" 289 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ ftw::+tvs-haslines+ ftw::+tvs-linesatroot+ ftw::+tvs-hasbuttons+) 290 | :ex-styles ftw::+ws-ex-clientedge+ 291 | :x 0 :y 0 :width 200 :height 200 292 | :parent hwnd))) 293 | 294 | (set-default-font h) 295 | 296 | (let ((il (imagelist-create 32 32))) 297 | (imagelist-add il *test2-bitmap*) 298 | (treeview-set-imagelist h il)) 299 | 300 | (let ((parent (ftw::treeview-insert-item h "Parent" :insert-after :root :image 0 :selected-image 0))) 301 | (ftw::treeview-insert-item h "Child" :insert-after :last :parent parent)) 302 | 303 | nil)) 304 | 305 | (defwndproc treeview-wndproc (hwnd msg wparam lparam) 306 | (switch msg 307 | ((const +wm-create+) 308 | (treeview-create hwnd)) 309 | ((const +wm-destroy+) 310 | (post-quit-message))) 311 | (default-window-proc hwnd msg wparam lparam)) 312 | 313 | (defun treeview () 314 | (default-message-loop 'treeview-wndproc 315 | :class-name "FTW_TREEVIEW" 316 | :title "Treeview" 317 | :width 400 :height 400)) 318 | 319 | 320 | -------------------------------------------------------------------------------- /examples/turtle/turtle.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | ;;; This file defines a simple little turtle type program. 5 | ;;; Users should be able program its movements like you would with Logo. 6 | ;;; 7 | ;;; Commands: 8 | ;;; move 9 | ;;; left 10 | ;;; right 11 | ;;; colour 12 | ;;; up ;; set pen up, i.e. don't draw lines 13 | ;;; down ;; set pen down, i.e. draw lines as turtle moves 14 | 15 | (eval-when (:load-toplevel :compile-toplevel :execute) 16 | (ql:quickload "parse-number")) 17 | 18 | (defpackage #:ftw.turtle 19 | (:use #:cl #:cffi #:ftw) 20 | (:export #:turtle)) 21 | 22 | (in-package #:ftw.turtle) 23 | 24 | (defstruct turtle 25 | x y ;; current position 26 | theta ;; forward direction, measured in radians 27 | pen ;; pen colour 28 | pen-p ;; pen up or down? 29 | hdc ;; device context for drawing 30 | commands ;; commands to execute 31 | prev-commands ;; previous command history 32 | ) 33 | 34 | 35 | (defparameter *turtle* nil) 36 | (defconstant +2pi+ (* 2.0 pi)) 37 | (defconstant +turtle-size+ 10) 38 | 39 | (defun degrees-radians (degrees) 40 | (* degrees (/ +2pi+ 360.0))) 41 | (defun radians-degrees (radians) 42 | (* radians (/ 360.0 +2pi+))) 43 | 44 | ;; turtle commands 45 | (defun turtle-right (theta &optional (turtle *turtle*)) 46 | (setf (turtle-theta turtle) 47 | (+ (turtle-theta turtle) theta))) 48 | (defun turtle-left (theta &optional (turtle *turtle*)) 49 | (turtle-right (- theta) turtle)) 50 | (defun turtle-move (distance &optional (turtle *turtle*)) 51 | (let ((x (turtle-x turtle)) 52 | (y (turtle-y turtle)) 53 | (theta (degrees-radians (turtle-theta turtle)))) 54 | 55 | (incf (turtle-x turtle) (* distance (cos theta))) 56 | (incf (turtle-y turtle) (* distance (sin theta))) 57 | 58 | ;; draw line if pen up 59 | (when (turtle-pen-p turtle) 60 | (move-to (turtle-hdc turtle) x y) 61 | (select-object (turtle-hdc turtle) (get-stock-object :dc-pen)) 62 | (line-to (turtle-hdc turtle) (turtle-x turtle) (turtle-y turtle))))) 63 | (defun turtle-pen-up (&optional (turtle *turtle*)) 64 | (setf (turtle-pen-p turtle) nil)) 65 | (defun turtle-pen-down (&optional (turtle *turtle*)) 66 | (setf (turtle-pen-p turtle) t)) 67 | (defun set-turtle-pen (pen &optional (turtle *turtle*)) 68 | (setf (turtle-pen turtle) pen) 69 | (set-dc-pen-color (turtle-hdc turtle) pen)) 70 | 71 | 72 | 73 | 74 | (defun draw-turtle (&optional (turtle *turtle*)) 75 | "The turtle is a triangle with two smaller triangles for legs" 76 | (let ((hdc (turtle-hdc turtle)) 77 | (theta (degrees-radians (turtle-theta turtle)))) 78 | (select-object (turtle-hdc turtle) (get-stock-object :white-pen)) 79 | 80 | ;; move out to leading vertex of turtle 81 | (move-to hdc 82 | (+ (turtle-x turtle) (* +turtle-size+ (cos theta))) 83 | (+ (turtle-y turtle) (* +turtle-size+ (sin theta)))) 84 | ;; draw to bottom right vertex 85 | (line-to hdc 86 | (+ (turtle-x turtle) (* +turtle-size+ (cos (+ theta (* 2/3 pi))))) 87 | (+ (turtle-y turtle) (* +turtle-size+ (sin (+ theta (* 2/3 pi)))))) 88 | ;; draw to bottom left vertex 89 | (line-to hdc 90 | (+ (turtle-x turtle) (* +turtle-size+ (cos (+ theta (* 4/3 pi))))) 91 | (+ (turtle-y turtle) (* +turtle-size+ (sin (+ theta (* 4/3 pi)))))) 92 | ;; draw line back to top vertex 93 | (line-to hdc 94 | (+ (turtle-x turtle) (* +turtle-size+ (cos theta))) 95 | (+ (turtle-y turtle) (* +turtle-size+ (sin theta)))) 96 | ;; draw little pen line 97 | (move-to hdc 98 | (+ (turtle-x turtle) (* (- +turtle-size+ 5) (cos theta))) 99 | (+ (turtle-y turtle) (* (- +turtle-size+ 5) (sin theta)))) 100 | (line-to hdc 101 | (+ (turtle-x turtle) (* (+ +turtle-size+ 5) (cos theta))) 102 | (+ (turtle-y turtle) (* (+ +turtle-size+ 5) (sin theta)))) 103 | 104 | ;; draw little legs? 105 | ;; TODO 106 | nil)) 107 | 108 | (defun eval-turtle-command (command &optional (turtle *turtle*)) 109 | (destructuring-bind (cmd &rest args) command 110 | (ecase cmd 111 | (left (turtle-left (car args) turtle)) 112 | (right (turtle-right (car args) turtle)) 113 | (move (turtle-move (car args) turtle)) 114 | (up (turtle-pen-up turtle)) 115 | (down (turtle-pen-down turtle)) 116 | ((color colour) 117 | (set-turtle-pen 118 | (let ((name (car args))) 119 | (cond 120 | ((keywordp name) 121 | (ecase name 122 | (:blue (encode-rgb 0 0 255)) 123 | (:green (encode-rgb 0 255 0)) 124 | (:red (encode-rgb 255 0 0)) 125 | (:yellow (encode-rgb 255 255 0)) 126 | (:white (encode-rgb 255 255 255)) 127 | (:black (encode-rgb 0 0 0)))) 128 | (t 129 | (destructuring-bind (r g b) args 130 | (encode-rgb r g b))))) 131 | turtle)))) 132 | 133 | (setf (turtle-prev-commands turtle) 134 | (append (turtle-prev-commands turtle) (list command)))) 135 | 136 | (defun eval-turtle (commands &optional (turtle *turtle*)) 137 | (dolist (c commands) 138 | (eval-turtle-command c turtle))) 139 | 140 | (defun parse-turtle-command (string) 141 | (ignore-errors 142 | (let ((index (or (position #\space string :test #'char=) 143 | (position #\return string :test #'char=) 144 | (position #\newline string :test #'char=)))) 145 | (cond 146 | ((string-equal (subseq string 0 index) "left") 147 | (list 'left 148 | (parse-number:parse-number string :start (1+ index)))) 149 | ((string-equal (subseq string 0 index) "right") 150 | (list 'right 151 | (parse-number:parse-number string :start (1+ index)))) 152 | ((string-equal (subseq string 0 index) "move") 153 | (list 'move (parse-number:parse-number string :start (1+ index)))) 154 | ((string-equal (subseq string 0 index) "up") 155 | (list 'up)) 156 | ((string-equal (subseq string 0 index) "down") 157 | (list 'down)) 158 | ((or (string-equal (subseq string 0 index) "colour") 159 | (string-equal (subseq string 0 index) "color")) 160 | (let* ((c :white) 161 | (pos (position #\space string)) 162 | (cstr (string-trim '(#\space #\return #\newline) (subseq string (1+ (or pos index)))))) 163 | (setf c 164 | (cond 165 | ((string-equal cstr "white") :white) 166 | ((string-equal cstr "black") :black) 167 | ((string-equal cstr "yellow") :yellow) 168 | ((string-equal cstr "blue") :blue) 169 | ((string-equal cstr "green") :green) 170 | ((string-equal cstr "red") :red) 171 | (t :white))) 172 | (list 'colour c))))))) 173 | 174 | 175 | (defun parse-turtle-commands (string) 176 | (with-input-from-string (s string) 177 | (do ((l (read-line s nil nil) (read-line s nil nil)) 178 | (cmds nil)) 179 | ((null l) (nreverse cmds)) 180 | (let ((cmd (parse-turtle-command l))) 181 | (when cmd 182 | (push cmd cmds)))))) 183 | 184 | ;; ------------ GUI ----------------- 185 | 186 | 187 | 188 | ;; we define a turtle window class whcih is just for the turtle to move around in 189 | ;; we can then place this whereever we want on the main gui 190 | 191 | (defvar *wm-turtle* (register-window-message "WM_TURTLE")) 192 | (defparameter *turtle-label* nil) 193 | 194 | (defwndproc turtle-wndproc (hwnd msg wparam lparam) 195 | (switch msg 196 | ((const +wm-create+) 197 | (destructuring-bind (&key left top (right 0) (bottom 0)) (get-client-rect hwnd) 198 | (declare (ignore left top)) 199 | (setf *turtle* (make-turtle :x (truncate right 2) :y (truncate bottom 2) :theta 0 :pen-p t)))) 200 | ((const +wm-paint+) 201 | (with-paint (hwnd hdc) 202 | ;; set brushes 203 | (select-object hdc (get-stock-object :black-brush)) 204 | (select-object hdc (get-stock-object :white-pen)) 205 | 206 | ;; set turtle device context 207 | (setf (turtle-hdc *turtle*) hdc) 208 | 209 | ;; evaluate all previous and new commands 210 | (let ((prev (turtle-prev-commands *turtle*))) 211 | (destructuring-bind (&key left top (right 0) (bottom 0)) (get-client-rect hwnd) 212 | (declare (ignore left top)) 213 | (setf (turtle-x *turtle*) (truncate right 2) 214 | (turtle-y *turtle*) (truncate bottom 2) 215 | (turtle-theta *turtle*) 0 216 | (turtle-pen-p *turtle*) t)) 217 | (setf (turtle-prev-commands *turtle*) nil) 218 | (eval-turtle prev) 219 | (eval-turtle (turtle-commands *turtle*)) 220 | (draw-turtle)) 221 | 222 | (setf (turtle-commands *turtle*) nil) 223 | 224 | (set-window-text *turtle-label* (turtle-label-text)))) 225 | ((const +wm-size+) 226 | (invalidate-rect hwnd nil t) 227 | (update-window hwnd)) 228 | (*wm-turtle* 229 | ;; our custom message -- this sends us various commands 230 | nil)) 231 | (default-window-proc hwnd msg wparam lparam)) 232 | 233 | (register-class "TURTLE" (callback turtle-wndproc) 234 | :background (get-stock-object :black-brush)) 235 | 236 | 237 | 238 | 239 | 240 | ;; -------------------- Main GUI --------------------- 241 | 242 | 243 | 244 | ;; we want the turtle to be on the left maybe with x/y/theta/pen info in a static label 245 | ;; on the right should be an edit control to accept commands 246 | 247 | (defparameter *turtle-edit* nil) 248 | (defparameter *turtle-wnd* nil) 249 | (defparameter *turtle-button* nil) 250 | (defparameter *turtle-reset* nil) 251 | (defparameter *turtle-help* nil) 252 | 253 | (defun turtle-label-text () 254 | (format nil "X ~,3F Y ~,3F THETA ~,3F ~A" 255 | (turtle-x *turtle*) (turtle-y *turtle*) 256 | (turtle-theta *turtle*) 257 | (if (turtle-pen-p *turtle*) "Down" "Up"))) 258 | 259 | (defun turtle-create (hwnd) 260 | (destructuring-bind (&key left top right bottom) (get-client-rect hwnd) 261 | (declare (ignore left top)) 262 | 263 | (setf *turtle* (make-turtle :x 0 :y 0 :theta 0)) 264 | 265 | ;; put static label for turtle info in top left 266 | (setf *turtle-label* 267 | (create-window :static 268 | :window-name (turtle-label-text) 269 | :styles (logior-consts +ws-visible+ +ws-child+) 270 | :x 25 :y 25 :width (- right 275) :height 25 271 | :parent hwnd)) 272 | 273 | ;; put turtle window below it 274 | (setf *turtle-wnd* 275 | (create-window "TURTLE" 276 | :styles (logior-consts +ws-visible+ +ws-child+ +ws-border+) 277 | :parent hwnd 278 | :x 25 :y 75 :width (- right 275) :height (- bottom 100))) 279 | (unless *turtle-wnd* (ftw::get-last-error)) 280 | 281 | ;; edit control on right for entering command s 282 | (setf *turtle-edit* 283 | (create-window :edit 284 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+ ftw::+es-multiline+ ftw::+ws-border+) 285 | :ex-styles ftw::+ws-ex-clientedge+ 286 | :x (- right 225) :y 25 :width 200 :height (- bottom 150) 287 | :parent hwnd 288 | :menu 1)) 289 | 290 | (setf *turtle-button* 291 | (create-window :button 292 | :window-name "Done" 293 | :styles (logior-consts +ws-visible+ +ws-child+) 294 | :x (- right 255) :y (- bottom 50) :width 25 :height 25 295 | :parent hwnd 296 | :menu 2) 297 | *turtle-reset* 298 | (create-window :button 299 | :window-name "Reset" 300 | :styles (logior-consts +ws-visible+ +ws-child+) 301 | :x (- right 200) :y (- bottom 50) :width 25 :height 25 302 | :parent hwnd 303 | :menu 3) 304 | *turtle-help* 305 | (create-window :button 306 | :window-name "Help" 307 | :styles (logior ftw::+ws-visible+ ftw::+ws-child+) 308 | :x (- right 220) :y (- bottom 50) :width 25 :height 25 309 | :parent hwnd 310 | :menu 4)) 311 | 312 | (set-focus *turtle-edit*))) 313 | 314 | (defun turtle-resize (hwnd) 315 | (destructuring-bind (&key left top right bottom) (get-client-rect hwnd) 316 | (declare (ignore left top)) 317 | (when *turtle-wnd* 318 | (set-window-pos *turtle-wnd* :top 25 75 (- right 275) (- bottom 100))) 319 | (when *turtle-edit* 320 | (set-window-pos *turtle-edit* :top (- right 225) 75 200 (- bottom 150))) 321 | (when *turtle-button* 322 | (set-window-pos *turtle-button* :top (- right 185) (- bottom 50) 75 25)) 323 | (when *turtle-reset* 324 | (set-window-pos *turtle-reset* :top (- right 100) (- bottom 50) 75 25)) 325 | (when *turtle-help* 326 | (set-window-pos *turtle-help* :top (- right 225) 25 75 25)) 327 | (when *turtle-label* 328 | (set-window-text *turtle-label* (turtle-label-text))))) 329 | 330 | 331 | (defwndproc turtle-main-wndproc (hwnd msg wparam lparam) 332 | (switch msg 333 | ((const +wm-create+) 334 | (turtle-create hwnd)) 335 | ((const +wm-destroy+) 336 | (post-quit-message)) 337 | ((const +wm-size+) 338 | (turtle-resize hwnd)) 339 | ((const +wm-command+) 340 | (switch (loword wparam) 341 | (1 ;; edit text box 342 | nil) 343 | (2 ;; button 344 | ;; parse commands 345 | (let ((commands (parse-turtle-commands (get-window-text *turtle-edit*)))) 346 | 347 | (setf (turtle-commands *turtle*) commands) 348 | (invalidate-rect *turtle-wnd* nil t) 349 | 350 | ;; clear trext box 351 | (set-window-text *turtle-edit* ""))) 352 | (3 ;; reset button 353 | (destructuring-bind (&key left top (right 0) (bottom 0)) (get-client-rect hwnd) 354 | (declare (ignore left top)) 355 | (setf *turtle* (make-turtle :x (truncate right 2) :y (truncate bottom 2) :theta 0 :pen-p t))) 356 | (invalidate-rect *turtle-wnd* nil t)) 357 | (4 ;;help 358 | (message-box :hwnd hwnd 359 | :text 360 | (format nil " 361 | Turtle program. Type commands into the text box and press Done. 362 | Commands: 363 | move 364 | left 365 | right 366 | colour 367 | up 368 | down 369 | 370 | ") 371 | :caption "Help" 372 | :icon :information))))) 373 | (default-window-proc hwnd msg wparam lparam)) 374 | 375 | (defun turtle () 376 | (default-message-loop (callback turtle-main-wndproc) 377 | :class-name "TURTLE_WINDOW" 378 | :title "Turtle" 379 | :width 600 :height 400)) 380 | 381 | 382 | 383 | 384 | 385 | -------------------------------------------------------------------------------- /ftw.asd: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | (asdf:defsystem :ftw 5 | :name "ftw" 6 | :author "Frank James " 7 | :description "Common Lisp For the Win(32). A very thin layer over the top of Win32 GUI APIs." 8 | :license "MIT" 9 | :serial t 10 | :components 11 | ((:file "package") 12 | (:file "constants") 13 | (:file "ffi") 14 | (:file "ftw")) 15 | :depends-on (:cffi :alexandria :nibbles)) 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /ftw.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) Frank James 2016 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | 5 | ;;; This file defines useful utility functions and macros to simplify some common tasks. 6 | 7 | (in-package #:ftw) 8 | 9 | 10 | (defvar *accel* nil 11 | "FTW's global accelerator table.") 12 | 13 | (defun set-accelerator-table (&optional entries) 14 | "Destroy the existing accelerator table (if any) and set new table. 15 | ENTRIES ::= new accelerator table to set. 16 | 17 | The existing accelerator table is always destroyed. If ENTRIES is non-nil 18 | then a new table is set. 19 | " 20 | (when *accel* 21 | (destroy-accelerator-table *accel*) 22 | (setf *accel* nil)) 23 | (when entries 24 | (setf *accel* (create-accelerator-table entries)))) 25 | 26 | 27 | (defun default-message-loop (wndproc &key class-name title width height background icon icon-small styles) 28 | "Standard message loop. Defines a new window class with :arrow cursor and 3d-face background, 29 | creates an overlapped, visible window of this class. Shows, updates and sets this window to 30 | the foreground. Then loops, processing messages, until a WM_QUIT message is received. 31 | 32 | Also processes accelerator keys set using SET-ACCELERATOR-TABLE. 33 | " 34 | (let ((cname (or class-name "FTW_MAIN_CLASS"))) 35 | (register-class cname 36 | wndproc 37 | :icon icon 38 | :icon-small icon-small 39 | :cursor (load-cursor :arrow) 40 | :background (or background (get-sys-color-brush :3d-face))) 41 | (let ((hwnd (create-window cname 42 | :window-name (or title cname) 43 | :ex-styles (logior-consts +ws-ex-appwindow+) 44 | :styles (or styles 45 | (logior +ws-overlappedwindow+ +ws-visible+)) 46 | :x 100 :y 100 :width (or width 400) :height (or height 300))) 47 | (msg (make-msg))) 48 | (unless hwnd (return-from default-message-loop nil)) 49 | 50 | (show-window hwnd) 51 | (update-window hwnd) 52 | (set-foreground-window hwnd) 53 | (do ((done nil)) 54 | (done) 55 | (let ((r (get-message msg))) 56 | (cond 57 | ((zerop r) (setf done t)) 58 | ((or (null *accel*) 59 | (zerop (translate-accelerator hwnd *accel* msg))) 60 | (translate-message msg) 61 | (dispatch-message msg)))))))) 62 | 63 | (defun default-message-loop-multiple (wndproc &key class-name title width height background icon icon-small styles handle-procs) 64 | "Message loop with multiple handles. Defines a new window class with :arrow cursor and 3d-face background, 65 | creates an overlapped, visible window of this class. Shows, updates and sets this window to 66 | the foreground. Then loops, processing messages, until a WM_QUIT message is received. 67 | 68 | Also processes accelerator keys set using SET-ACCELERATOR-TABLE. 69 | " 70 | (let ((cname (or class-name "FTW_MAIN_CLASS")) 71 | (handles (mapcar #'first handle-procs)) 72 | (procs (mapcar #'second handle-procs))) 73 | (register-class cname 74 | wndproc 75 | :icon icon 76 | :icon-small icon-small 77 | :cursor (load-cursor :arrow) 78 | :background (or background (get-sys-color-brush :3d-face))) 79 | (let ((hwnd (create-window cname 80 | :window-name (or title cname) 81 | :ex-styles (logior-consts +ws-ex-appwindow+) 82 | :styles (or styles 83 | (logior +ws-overlappedwindow+ +ws-visible+)) 84 | :x 100 :y 100 :width (or width 400) :height (or height 300))) 85 | (msg (make-msg))) 86 | (unless hwnd (return-from default-message-loop-multiple nil)) 87 | 88 | (show-window hwnd) 89 | (update-window hwnd) 90 | (set-foreground-window hwnd) 91 | (do ((done nil)) 92 | (done) 93 | (let ((sts (msg-wait-for-multiple-objects :handles handles :timeout 500))) 94 | (cond 95 | ((= sts (length handles)) 96 | ;; messages pending 97 | (do ((b (peek-message msg :error-p nil) (peek-message msg :error-p nil))) 98 | ((or (not b) done)) 99 | (let ((r (get-message msg))) 100 | (cond 101 | ((zerop r) (setf done t)) 102 | ((or (null *accel*) 103 | (zerop (translate-accelerator hwnd *accel* msg))) 104 | (translate-message msg) 105 | (dispatch-message msg)))))) 106 | ((and (>= sts 0) (< sts (length handles))) 107 | ;; handle signaled - invoke specified callback 108 | (apply (nth sts procs) 109 | (cddr (nth sts handle-procs)))))))))) 110 | 111 | 112 | (defun message-poll (&optional timeout) 113 | "Wait for messages to be available in the message queue." 114 | (msg-wait-for-multiple-objects :timeout timeout 115 | :mask (logior-consts +qs-allevents+))) 116 | 117 | 118 | (defun create-bitmap-resource (width height planes bits-per-pixel data) 119 | "Create a colour bitmap. Data should be a vector of (unsigned-byte 8) of 120 | the correct length and alignment for the colour data." 121 | (let ((bm (create-dib-section nil width height planes bits-per-pixel))) 122 | (set-di-bits nil bm width height planes bits-per-pixel data) 123 | bm)) 124 | 125 | (defun generate-bitmap-resource (filename &optional (stream *standard-output*) name) 126 | "Parse a bitmap file and generate Lisp code so that the resource can be embedded 127 | within a Lisp program rather than having to deliver the image separately. 128 | The function prints out the code to be inserted into your project. 129 | 130 | FILENAME ::= path to a .bmp bitmap file on your system. 131 | This function loads the data and parses it for width/height information. It then 132 | prints out a Lisp form which should be pasted into your code for use as a bitmap handle. 133 | This allows the programmer to embed images without having to deliver them as separate files. 134 | " 135 | (with-open-file (f filename :direction :input :element-type '(unsigned-byte 8)) 136 | (let ((len (file-length f))) 137 | (let ((bmp (make-array len :element-type '(unsigned-byte 8)))) 138 | (read-sequence bmp f) 139 | 140 | ;; extract dimensions from header -- see MSDN page for more info on bitmap stuctures 141 | ;; https://msdn.microsoft.com/en-us/library/windows/desktop/dd183391(v=vs.85).aspx 142 | (let ((offset (nibbles:ub32ref/le bmp 10)) 143 | (width (nibbles:sb32ref/le bmp 18)) 144 | (height (nibbles:sb32ref/le bmp 22)) 145 | (planes (nibbles:ub16ref/le bmp 26)) 146 | (bits-per-pixel (nibbles:ub16ref/le bmp 28))) 147 | 148 | (format stream "(defvar ~A~%" (or name "NAME")) 149 | (format stream " (create-bitmap-resource ~A ~A ~A ~A~%#( " 150 | width height planes bits-per-pixel) 151 | 152 | ;; bitmap stores it as aa rr gg bb 153 | ;; we want it as bb gg rr aa 154 | ;; BUT: we need to use premultiplied alpha 155 | (do ((i 0 (+ i 4))) 156 | ((= i (- (length bmp) offset))) 157 | (let ((aa (aref bmp (+ offset i 0))) 158 | (bb (aref bmp (+ offset i 1))) 159 | (gg (aref bmp (+ offset i 2))) 160 | (rr (aref bmp (+ offset i 3)))) 161 | (setf (aref bmp (+ offset i 0)) 162 | (truncate (* bb aa) #xff) 163 | (aref bmp (+ offset i 1)) 164 | (truncate (* gg aa) #xff) 165 | (aref bmp (+ offset i 2)) 166 | (truncate (* rr aa) #xff) 167 | (aref bmp (+ offset i 3)) 168 | aa))) 169 | 170 | (dotimes (i (- (length bmp) offset)) 171 | (when (and (not (zerop i)) (zerop (mod i 16))) 172 | (when (zerop (mod i 256)) 173 | (terpri stream)) 174 | (format stream "~% ")) 175 | (when (zerop (mod i 4)) 176 | (format stream " ")) 177 | (format stream "#x~2,'0X " (aref bmp (+ offset i)))) 178 | (format stream ")))~%")) 179 | 180 | nil)))) 181 | 182 | (defun get-default-font () 183 | "Returns the default system message font." 184 | (create-font-indirect (nonclientmetrics-message-font (system-parameters-info (const +spi-getnonclientmetrics+))))) 185 | 186 | (defun set-default-font (hwnd &optional font) 187 | "Send a WM_SETFONT message to the window with the specified font. 188 | If FONT is not specified, the default system message font is used. 189 | " 190 | (send-message hwnd (const +wm-setfont+) (or font (get-default-font)) 0)) 191 | 192 | 193 | (defun generate-icon-resource (filename &optional (stream *standard-output*) name) 194 | "Generate Lisp code for a given icon so that it can be embedded into 195 | Lisp code. This means you don't have to deliver the icon file separately. 196 | This is equivalent to the .rc resources you link with when writing C. 197 | 198 | FILENAME ::= path to a .ico file containing the icon you want to use. 199 | Prints out code which should be included into your project. 200 | " 201 | (with-open-file (f filename :direction :input :element-type '(unsigned-byte 8)) 202 | (let ((len (file-length f))) 203 | (let ((ico (make-array len :element-type '(unsigned-byte 8)))) 204 | (read-sequence ico f) 205 | 206 | ;; icon file header -- see wikipedia entry for details 207 | (let ((type (nibbles:ub16ref/le ico 2)) 208 | (width (aref ico 6)) 209 | (height (aref ico 7)) 210 | (planes (nibbles:ub16ref/le ico 10)) 211 | (bits-per-pixel (nibbles:ub16ref/le ico 12)) 212 | ;; (size (nibbles:ub32ref/le ico 14)) 213 | (offset (+ (nibbles:ub32ref/le ico 18) 40))) 214 | 215 | (unless (= type 1) (error "Expected type 2 got ~A" type)) 216 | 217 | (format stream "(defvar ~A~%" (or name "NAME")) 218 | (format stream " (create-icon ~A ~A ~A ~A~%" 219 | width height planes bits-per-pixel) 220 | (format stream " (make-array ~A :element-type '(unsigned-byte 8))~%" 221 | (- (length ico) offset)) 222 | (format stream " #(") 223 | (dotimes (i (- (length ico) offset)) 224 | (when (and (not (zerop i)) (zerop (mod i 16))) 225 | (format stream "~% ")) 226 | (format stream "#x~2,'0X " (aref ico (+ offset i)))) 227 | (format stream ")))~%")) 228 | 229 | nil)))) 230 | 231 | (defun generate-cursor-resource (filename &optional (stream *standard-output*) name) 232 | "Generate Lisp code for a given cursor so that it can be embedded into 233 | Lisp code. This means you don't have to deliver the cursor file separately. 234 | This is equivalent to the .rc resources you link with when writing C. 235 | 236 | FILENAME ::= path to a .cur file containing the cursor you want to use. 237 | Prints out code which should be included into your project. 238 | " 239 | 240 | (with-open-file (f filename :direction :input :element-type '(unsigned-byte 8)) 241 | (let ((len (file-length f))) 242 | (let ((ico (make-array len :element-type '(unsigned-byte 8)))) 243 | (read-sequence ico f) 244 | 245 | ;; icon file header -- see wikipedia entry for details 246 | (let ((type (nibbles:ub16ref/le ico 2)) 247 | (width (aref ico 6)) 248 | (height (aref ico 7)) 249 | (x (nibbles:ub16ref/le ico 10)) 250 | (y (nibbles:ub16ref/le ico 12)) 251 | ;; (size (nibbles:ub32ref/le ico 14)) 252 | (offset (+ (nibbles:ub32ref/le ico 18) 40))) 253 | 254 | (unless (= type 2) (error "Expected type 2 got ~A" type)) 255 | 256 | (format stream "(defvar ~A~%" (or name "NAME")) 257 | (format stream " (create-cursor ~A ~A ~A ~A~%" 258 | x y width height ) 259 | (format stream " (make-array ~A :element-type '(unsigned-byte 8))~%" 260 | (- (length ico) offset)) 261 | (format stream " #(") 262 | (dotimes (i (- (length ico) offset)) 263 | (when (and (not (zerop i)) (zerop (mod i 16))) 264 | (format stream "~% ")) 265 | (format stream "#x~2,'0X " (aref ico (+ offset i)))) 266 | (format stream ")))~%")) 267 | 268 | nil)))) 269 | 270 | (defun generate-resource-file (filename resources &key package) 271 | (with-open-file (stream filename :direction :output :if-exists :supersede) 272 | (format stream "~%") 273 | (format stream "(in-package #:~A)~%" (or package (package-name *package*))) 274 | (format stream "~%") 275 | (dolist (resource resources) 276 | (destructuring-bind (res-type &rest res-args) resource 277 | (ecase res-type 278 | (:icon 279 | (destructuring-bind (name icon-filename) res-args 280 | (generate-icon-resource icon-filename stream name))) 281 | (:cursor 282 | (destructuring-bind (name cursor-filename) res-args 283 | (generate-cursor-resource cursor-filename stream name))) 284 | (:bitmap 285 | (destructuring-bind (name bitmap-filename) res-args 286 | (generate-bitmap-resource bitmap-filename stream name)))))) 287 | (format stream "~%"))) 288 | 289 | (defun get-client-size (hwnd) 290 | "Get width and height of the hwnd. Returns (values width height)." 291 | (let ((r (get-client-rect hwnd))) 292 | (values (getf r :right 0) 293 | (getf r :bottom 0)))) 294 | 295 | 296 | (defun add-menu-bar (hwnd menus) 297 | "Add menu bar to the window. 298 | MENUS ::= MENU* 299 | MENU ::= type flags &key name id children 300 | where 301 | TYPE ::= :menu | :item | :check | :radio 302 | FLAGS ::= list of flags to be passed to append-menu 303 | NAME ::= string naming the item 304 | ID ::= integer identifier 305 | CHILDREN ::= MENU* menu children 306 | " 307 | ;; Example 308 | ;; (add-menu-bar `((:menu (:popup) :name "&File" 309 | ;; :children 310 | ;; ((:item (:string) 311 | ;; :name ,(format nil "&Find~ACtrl+F" #\tab) 312 | ;; :id 1) 313 | ;; (:item (:separator)) 314 | ;; (:item (:string) 315 | ;; :name ,(format nil "&Quit~ACtrl+Q" #\tab) 316 | ;; :id 2))))) 317 | 318 | (labels ((process-menu (parent menu) 319 | (destructuring-bind (type flags &key name id children) menu 320 | (ecase type 321 | (:menu 322 | (let ((m (create-menu))) 323 | (dolist (child children) 324 | (process-menu m child)) 325 | (append-menu parent flags m name))) 326 | (:item 327 | (append-menu parent flags (or id 0) name)) 328 | (:check 329 | (check-menu-item parent (or id 0) (member :checked flags))) 330 | (:radio 331 | (check-menu-radio-item parent 332 | (first flags) (second flags) 333 | (or id 0))))))) 334 | (let ((bar (create-menu))) 335 | (dolist (menu menus) 336 | (process-menu bar menu)) 337 | 338 | (set-menu hwnd bar)))) 339 | 340 | 341 | (defun set-window-to-center (hwnd) 342 | (let ((rect (get-window-rect hwnd))) 343 | (destructuring-bind (&key (left 0) (right 0) (top 0) (bottom 0)) rect 344 | (set-window-pos hwnd 345 | :topmost 346 | (truncate (- (get-system-metrics :cx-screen) 347 | (- right left)) 348 | 2) 349 | (truncate (- (get-system-metrics :cy-screen) 350 | (- bottom top)) 351 | 2) 352 | 0 353 | 0 354 | '(:no-size))))) 355 | 356 | 357 | (defmacro with-double-buffering ((var hwnd) &body body) 358 | "Evaluate body in a WITH-PAINT context where VAR is bound to an in-memory HDC 359 | which is blitted onto the hwnd's DC as the final step. This prevents flickering 360 | when drawing lots of small items on the screen." 361 | (alexandria:with-gensyms (gbm gold gwidth gheight ghdc gps) 362 | `(with-paint (,hwnd ,ghdc ,gps) 363 | (let ((,gwidth (rect-right (paintstruct-paint ,gps))) 364 | (,gheight (rect-bottom (paintstruct-paint ,gps)))) 365 | (with-compatible-dc (,var ,ghdc) 366 | (let* ((,gbm (create-compatible-bitmap ,ghdc ,gwidth ,gheight)) 367 | (,gold (select-object ,var ,gbm))) 368 | (unwind-protect (progn ,@body) 369 | (bit-blt ,ghdc 0 0 ,var 0 0 370 | :width ,gwidth 371 | :height ,gheight 372 | :raster-op :srccopy) 373 | (select-object ,var ,gold) 374 | (delete-object ,gbm)))))))) 375 | 376 | 377 | (defmacro with-printer-dc ((var device-name &optional document-name) &body body) 378 | "Evaluate the body in a context with VAR bound to an HDC for the printer named by DEVICE-NAME. 379 | The body should consist of a series of PRINT-PAGE forms. Any other forms in body are evaulated but 380 | do not contribute to the page to be printed. 381 | 382 | For examples see examples/printer. 383 | " 384 | `(let ((,var (create-dc ,device-name))) 385 | (unwind-protect 386 | (macrolet ((print-page (&body body) 387 | `(progn (start-page ,',var) 388 | ,@body 389 | (end-page ,',var)))) 390 | (start-doc ,var ,(or document-name "Document")) 391 | ,@body 392 | (end-doc ,var)) 393 | (delete-dc ,var)))) 394 | 395 | (defun create-static (text &key parent styles font x y width height) 396 | (let ((h (create-window :static 397 | :window-name text 398 | :styles (cond 399 | (styles styles) 400 | (parent (logior ftw::+ws-visible+ ftw::+ws-child+))) 401 | :x x :y y :width width :height height 402 | :parent parent))) 403 | (set-default-font h font) 404 | h)) 405 | 406 | (defun create-edit (&key text parent styles font x y width height) 407 | (let ((h (create-window :edit 408 | :window-name (or text "") 409 | :styles (cond 410 | (styles styles) 411 | (parent (logior ftw::+ws-visible+ ftw::+ws-child+))) 412 | :ex-styles (logior ftw::+ws-ex-clientedge+) 413 | :x x :y y :width width :height height 414 | :parent parent))) 415 | (set-default-font h font) 416 | h)) 417 | 418 | (defun create-button (text &key parent styles font x y width height menu) 419 | (let ((h (create-window :button 420 | :window-name text 421 | :styles (cond 422 | (styles styles) 423 | (parent (logior ftw::+ws-visible+ ftw::+ws-child+))) 424 | :x x :y y :width width :height height 425 | :parent parent 426 | :menu menu))) 427 | (set-default-font h font) 428 | h)) 429 | 430 | 431 | 432 | (defparameter *hwnd-list* (make-hash-table)) 433 | (defun register-hwnd (name hwnd &optional (id 0)) 434 | (setf (gethash name *hwnd-list*) 435 | (list hwnd id)) 436 | name) 437 | (defun unregister-hwnd (name &rest more-names) 438 | (let ((nlist (cons name more-names))) 439 | (dolist (n nlist) 440 | (remhash n *hwnd-list*))) 441 | nil) 442 | (defun hwnd-by-name (name) 443 | (let ((n (gethash name *hwnd-list*))) 444 | (first n))) 445 | (defun hwnd-by-id (id) 446 | (maphash (lambda (key n) 447 | (declare (ignore key)) 448 | (when (= (second n) id) 449 | (return-from hwnd-by-id (first n)))) 450 | *hwnd-list*) 451 | nil) 452 | (defun hwnd-name-by-id (id) 453 | (maphash (lambda (key n) 454 | (when (= (second n) id) 455 | (return-from hwnd-name-by-id key))) 456 | *hwnd-list*)) 457 | (defun hwnd-list () 458 | (let ((hlist nil)) 459 | (maphash (lambda (key n) 460 | (push (cons key n) hlist)) 461 | *hwnd-list*) 462 | hlist)) 463 | 464 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:ftw 3 | (:use #:cl #:cffi) 4 | (:export ;; constants.lisp 5 | #:const 6 | #:logior-consts 7 | 8 | ;; ffi.lisp 9 | #:switch 10 | #:with-wide-string 11 | #:memset 12 | #:point 13 | #:wparam 14 | #:lparam 15 | #:msg 16 | #:make-msg 17 | #:msg-hwnd 18 | #:msg-message 19 | #:msg-wparam 20 | #:msg-lparam 21 | #:msg-time 22 | #:msg-pt 23 | #:msg-foreign 24 | #:foreign-msg 25 | #:get-message 26 | #:translate-message 27 | #:dispatch-message 28 | #:post-quit-message 29 | #:post-message 30 | #:send-message 31 | #:send-message-timeout 32 | #:register-window-message 33 | #:get-active-window 34 | #:defwndproc 35 | #:get-module-handle 36 | #:unregister-class 37 | #:register-class 38 | #:create-window 39 | #:message-box 40 | #:default-window-proc 41 | #:show-window 42 | #:update-window 43 | #:destroy-window 44 | #:get-stock-object 45 | #:get-sys-color-brush 46 | #:get-sys-color 47 | #:load-icon 48 | #:load-cursor 49 | #:load-image 50 | #:in-send-message-p 51 | #:enum-child-windows 52 | #:find-window 53 | #:get-parent 54 | #:make-rect 55 | #:rect-left 56 | #:rect-right 57 | #:rect-top 58 | #:rect-bottom 59 | #:rect-foreign 60 | #:foreign-rect 61 | #:info 62 | #:info-size 63 | #:info-window 64 | #:info-client 65 | #:info-style 66 | #:info-ex-style 67 | #:info-status 68 | #:info-borders 69 | #:info-type 70 | #:info-version 71 | #:get-window-info 72 | #:move-window 73 | #:set-window-text 74 | #:set-window-pos 75 | #:invalidate-rect 76 | #:invalidate-region 77 | #:paintstruct 78 | #:paintstruct-hdc 79 | #:paintstruct-erase 80 | #:paintstruct-paint 81 | #:paintstruct-restore 82 | #:paintstruct-inc-update 83 | #:paintstruct-foreign 84 | #:foreign-paintstruct 85 | #:begin-paint 86 | #:end-paint 87 | #:with-paint 88 | #:draw-caption 89 | #:draw-focus-rect 90 | #:draw-edge 91 | #:redraw-window 92 | #:text-out 93 | #:get-client-rect 94 | #:flash-window 95 | #:message-beep 96 | #:client-to-screen 97 | #:get-window-rect 98 | #:get-system-metrics 99 | #:register-hot-key 100 | #:unregister-hot-key 101 | #:encode-rgb 102 | #:decode-rgb 103 | #:create-solid-brush 104 | #:create-pen 105 | #:virtual-key-code 106 | #:virtual-code-key 107 | #:create-menu 108 | #:append-menu 109 | #:set-menu 110 | #:create-popup-menu 111 | #:delete-menu 112 | #:destroy-menu 113 | #:track-popup-menu 114 | #:check-menu-item 115 | #:check-menu-radio-item 116 | #:get-menu-state 117 | #:init-common-controls 118 | #:choose-color 119 | #:get-open-file-name 120 | #:get-save-file-name 121 | #:set-background-color 122 | #:ext-text-out 123 | #:is-dialog-button-checked 124 | #:check-dialog-button 125 | #:select-object 126 | #:delete-object 127 | #:set-timer 128 | #:kill-timer 129 | #:rectangle 130 | #:draw-text 131 | #:set-pixel 132 | #:get-pixel 133 | #:move-to 134 | #:line-to 135 | #:poly-bezier 136 | #:create-hatch-brush 137 | #:create-pattern-brush 138 | #:create-bitmap 139 | #:get-window-text-length 140 | #:get-window-text 141 | #:with-tool-info 142 | #:make-long 143 | #:make-lparam 144 | #:loword 145 | #:hiword 146 | #:nmhdr 147 | #:foreign-nmhdr 148 | #:nmhdr-foreign 149 | #:updown 150 | #:foreign-updown 151 | #:updown-foreign 152 | #:systemtime 153 | #:systemtime-year 154 | #:systemtime-month 155 | #:systemtime-day-of-week 156 | #:systemtime-day 157 | #:systemtime-hour 158 | #:systemtime-minute 159 | #:systemtime-second 160 | #:systemtime-milli 161 | #:foreign-systemtime 162 | #:systemtime-foreign 163 | #:tcitem 164 | #:tcitem-mask 165 | #:tcitem-state 166 | #:tcitem-state-mask 167 | #:tcitem-text 168 | #:tcitem-image 169 | #:tcitem-lparam 170 | #:foreign-tcitem 171 | #:tcitem-foreign 172 | #:create-font 173 | #:enum-font-families 174 | #:set-bk-mode 175 | #:set-bk-color 176 | #:ext-create-pen 177 | #:polygon 178 | #:ellipse 179 | #:round-rect 180 | #:chord 181 | #:polyline 182 | #:bit-blt 183 | #:mask-blt 184 | #:plg-blt 185 | #:stretch-blt 186 | #:transparent-blt 187 | #:pat-blt 188 | #:set-stretch-blt-mode 189 | #:get-stretch-blt-mode 190 | #:create-compatible-dc 191 | #:bitmap 192 | #:bitmap-type 193 | #:bitmap-width 194 | #:bitmap-height 195 | #:bitmap-width-bytes 196 | #:bitmap-planes 197 | #:bitmap-bits-per-pixel 198 | #:bitmap-bits 199 | #:extlogpen 200 | #:extlogpen-pen-style 201 | #:extlogpen-width 202 | #:extlogpen-brush-style 203 | #:extlogpen-color 204 | #:extlogpen-hatch 205 | #:extlogpen-entries 206 | #:logfont 207 | #:logfont-height 208 | #:logfont-width 209 | #:logfont-escapement 210 | #:logfont-orientation 211 | #:logfont-weight 212 | #:logfont-italic 213 | #:logfont-underline 214 | #:logfont-strikeout 215 | #:logfont-charset 216 | #:logfont-out-precision 217 | #:logfont-clip-precision 218 | #:logfont-quality 219 | #:logfont-pitch-and-family 220 | #:logfont-name 221 | #:get-object 222 | #:create-dc 223 | #:delete-dc 224 | #:nonclientmetrics 225 | #:nonclientmetrics-size 226 | #:nonclientmetrics-border-width 227 | #:nonclientmetrics-scroll-width 228 | #:nonclientmetrics-scroll-height 229 | #:nonclientmetrics-caption-width 230 | #:nonclientmetrics-caption-height 231 | #:nonclientmetrics-caption-font 232 | #:nonclientmetrics-small-caption-width 233 | #:nonclientmetrics-small-caption-height 234 | #:nonclientmetrics-small-caption-font 235 | #:nonclientmetrics-menu-width 236 | #:nonclientmetrics-menu-height 237 | #:nonclientmetrics-menu-font 238 | #:nonclientmetrics-status-font 239 | #:nonclientmetrics-message-font 240 | #:nonclientmetrics-padded-border-width 241 | #:system-parameters-info 242 | #:set-focus 243 | #:get-focus 244 | #:createstruct 245 | #:createstruct-param 246 | #:createstruct-instance 247 | #:createstruct-menu 248 | #:createstruct-parent-hwnd 249 | #:createstruct-cy 250 | #:createstruct-cx 251 | #:createstruct-y 252 | #:createstruct-x 253 | #:createstruct-styles 254 | #:createstruct-name 255 | #:createstruct-class-name 256 | #:createstruct-ex-styles 257 | #:foreign-createstruct 258 | #:is-dialog-message 259 | #:get-dc 260 | #:release-dc 261 | #:create-dialog 262 | #:dialog-box 263 | #:end-dialog 264 | #:enable-window 265 | #:get-class-info 266 | #:wndclassex 267 | #:wndclassex-size 268 | #:wndclassex-style 269 | #:wndclassex-wndproc 270 | #:wndclassex-class-extra 271 | #:wndclassex-wnd-extra 272 | #:wndclassex-instance 273 | #:wndclassex-icon 274 | #:wndclassex-cursor 275 | #:wndclassex-brush 276 | #:wndclassex-menu-name 277 | #:wndclassex-class-name 278 | #:wndclassex-icon-small 279 | #:default-dialog-proc 280 | #:is-window 281 | #:get-dialog-item 282 | #:get-dialog-control-id 283 | #:get-next-dialog-tabl-item 284 | #:map-dialog-rect 285 | #:get-next-dialog-group-item 286 | #:get-dialog-item-text 287 | #:set-dialog-item-text 288 | #:send-dialog-item-message 289 | #:create-accelerator-table 290 | #:destroy-accelerator-table 291 | #:translate-accelerator 292 | #:peek-message 293 | #:get-menu 294 | #:get-sub-menu 295 | #:copy-accelerator-table 296 | #:get-prop 297 | #:set-prop 298 | #:remove-prop 299 | #:enum-props 300 | #:set-class-pointer 301 | #:get-class-pointer 302 | #:set-window-pointer 303 | #:get-window-pointer 304 | #:set-active-window 305 | #:get-foreground-window 306 | #:set-foreground-window 307 | #:wait-message 308 | #:get-queue-status 309 | #:msg-wait-for-multiple-objects 310 | #:drag-accept-files 311 | #:drag-finish 312 | #:drag-query-files 313 | #:drag-query-point 314 | #:broadcast-system-message 315 | #:reply-message 316 | #:create-icon 317 | #:create-cursor 318 | #:destroy-icon 319 | #:draw-icon 320 | #:get-device-caps 321 | #:create-compatible-bitmap 322 | #:gradient-fill 323 | #:set-text-color 324 | #:get-text-color 325 | #:create-font-indirect 326 | #:create-dib-section 327 | #:set-di-bits 328 | #:with-dc 329 | #:with-compatible-dc 330 | #:alpha-blend 331 | #:choose-font 332 | #:page-setup-dialog 333 | #:print-dialog 334 | #:free-findreplace 335 | #:get-findmsgstring 336 | #:foreign-findreplace 337 | #:find-text 338 | #:replace-text 339 | #:open-printer 340 | #:start-doc-printer 341 | #:start-page-printer 342 | #:write-printer 343 | #:end-page-printer 344 | #:end-doc-printer 345 | #:close-printer 346 | #:create-caret 347 | #:destroy-caret 348 | #:show-caret 349 | #:hide-caret 350 | #:get-caret-pos 351 | #:set-caret-pos 352 | #:get-text-extent-point 353 | #:get-text-metrics 354 | #:get-keyboard-layout-name 355 | #:load-keyboard-layout 356 | #:is-window-enabled 357 | #:play-sound 358 | #:get-window 359 | #:pie 360 | #:arc 361 | #:arc-to 362 | #:angle-arc 363 | #:set-arc-direction 364 | #:get-arc-direction 365 | #:set-scroll-info 366 | #:get-scroll-info 367 | #:scroll-window-ex 368 | #:show-scroll-bar 369 | #:enable-scroll-bar 370 | #:create-emf 371 | #:play-emf 372 | #:delete-emf 373 | #:with-emf 374 | #:get-emf-bits 375 | #:set-emf-bits 376 | #:with-emf-from-bits 377 | #:enum-display-devices 378 | #:start-doc 379 | #:start-page 380 | #:end-doc 381 | #:end-page 382 | 383 | ;; ftw.lisp provides some extra useful utilities 384 | #:set-accelerator-table 385 | #:set-default-font 386 | #:default-message-loop 387 | #:message-poll 388 | #:create-bitmap-resource 389 | #:generate-bitmap-resource 390 | #:generate-icon-resource 391 | #:generate-cursor-resource 392 | #:get-default-font 393 | #:generate-resource-file 394 | #:get-client-size 395 | #:add-menu-bar 396 | #:set-window-to-center 397 | #:with-double-buffering 398 | #:with-printer-dc 399 | #:print-page 400 | 401 | #:treeview-insert-item 402 | #:treeview-delete-item 403 | #:treeview-delete-all-items 404 | #:treeview-expand 405 | #:treeview-select-drop-target 406 | #:treeview-get-edit-control 407 | #:treeview-set-imagelist 408 | #:imagelist-create 409 | #:imagelist-add 410 | 411 | #:create-static 412 | #:create-edit 413 | #:create-button 414 | 415 | #:default-message-loop-multiple 416 | 417 | #:register-hwnd 418 | #:hwnd-by-name 419 | #:hwnd-by-id 420 | #:hwnd-name-by-id 421 | 422 | #:listview-insert-column 423 | #:listview-insert-item 424 | #:listview-set-item 425 | #:get-cursor-position 426 | #:screen-to-client 427 | #:foreign-nmlistview 428 | 429 | #:create-combobox 430 | #:combobox-add-string 431 | #:combobox-del-string 432 | #:combobox-selection 433 | #:combobox-show-dropdown 434 | #:combobox-reset-content 435 | 436 | #:alloc-console 437 | #:free-console 438 | #:create-console-screen-buffer 439 | #:open-console-std-input 440 | #:open-console-std-output 441 | #:set-console-active-screen-buffer 442 | #:char-info-attributes 443 | #:char-info-attrs 444 | #:char-info 445 | #:string-info 446 | #:read-console-input 447 | #:read-console-output 448 | #:write-console-output 449 | #:write-console-string 450 | #:set-console-cursor-position 451 | #:scroll-console-screen-buffer 452 | #:fill-console-output-character 453 | #:fill-console-output-attribute 454 | #:get-console-display-mode 455 | #:read-console 456 | #:get-console-cursor-info 457 | #:set-console-cursor-info 458 | #:write-console 459 | #:get-std-handle 460 | #:set-console-text-attribute 461 | #:attach-console 462 | #:get-console-window 463 | #:get-console-screen-buffer-info 464 | #:set-console-screen-buffer-info 465 | #:close-handle 466 | #:get-console--title 467 | #:get-number-of-console-input-events 468 | #:set-std-handle 469 | #:set-console-title 470 | #:flush-console-input-buffer 471 | #:get-console-mode 472 | #:set-console-mode 473 | #:console-mode 474 | #:console-modes 475 | 476 | #:get-current-console-font 477 | #:set-current-console-font 478 | #:set-console-screen-buffer-size 479 | #:set-dc-pen-color 480 | #:get-dc-pen-color 481 | 482 | )) 483 | 484 | 485 | 486 | --------------------------------------------------------------------------------