From a2863d6a1eebc9d2e020d70d05ffb4ae7cd709a2 Mon Sep 17 00:00:00 2001
From: Frank James <frank.a.james@gmail.com>
Date: Wed, 19 Oct 2016 13:22:06 +0100
Subject: [PATCH] adding icon example

---
 .gitignore                      |   8 +-
 README.md                       | 146 +++++-----
 examples/dragdrop/dragdrop.lisp | 134 +++++-----
 examples/icon/icon.lisp         | 113 ++++++++
 examples/pong/pong.lisp         | 460 ++++++++++++++++----------------
 ffi.lisp                        | 100 ++++++-
 ftw.lisp                        |  84 +++---
 package.lisp                    |   7 +-
 8 files changed, 637 insertions(+), 415 deletions(-)
 create mode 100644 examples/icon/icon.lisp

diff --git a/.gitignore b/.gitignore
index f919bd1..80f2d7a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,4 @@
-
-## ignore emacs tmp files and fasls
-*.fasl
-*.lisp~
+
+## ignore emacs tmp files and fasls
+*.fasl
+*.lisp~
diff --git a/README.md b/README.md
index e8df659..12e5add 100644
--- a/README.md
+++ b/README.md
@@ -1,73 +1,73 @@
-
-# FTW - Common Lisp For the Win(32) 
-
-# 1. Introduction 
-This library provides a very thin interface to the underlying
-APIs for writing native Windows GUIs in Common Lisp.
-
-The intention is to be able to write the same sort of codes in Lisp as you
-would if writing normal Win32 GUIs in C. This also opens the possibility
-for writing other more generate graphical applications like games.
-
-# 2. Functions
-All underlying Win32 functions have Lisp equivalents, mostly with CamelCase replaced with the Lisp style kebab-case.
-
-Because this is a very thin wrapper over the top of the underlying Win32 API,
-it is assumed the user is at least familiar with the equivalent C programming.
-Documentation for each of the functions can be found on MSDN or any of
-the other C language resource.
-
-## 2.1 Limitations
-Several functions accept IDs for so called "resources", which normally get linked
-in with the object code by the resource compiler (when writing in C). For
-obviously reasons this is not possible when using Lisp.
-
-## 2.2 Lispy CLOS based interface
-It would be nice to have a more Lispy CLOS based interface where you
-can define classes, methods etc. This should be provided by a higher level
-library and does not belong here.
-
-## 2.3 Other platforms
-This is a Windows only library and does not work on any other platform.
-It is not a cross platform GUI library.
-
-# 3. Examples
-Various examples are provided which show various levels of abstractions and a
-good showcase of how to use it.
-
-## 3.1 Zetcode samples
-The rather comprehensive tutorial for the C programming language can be
-found here [zetcode website](http://zetcode.com/gui/winapi/).
-These have been translated to Lisp and show that the same GUIs can be written
-which correspond to largely the same structure.
-
-## 3.2 Climage
-This example GUI displays a two list boxes which show the packages and
-exported symbols. Clicking on a symbol displays the documentation for it.
-
-In addition, this GUI shows how to write and handle modal dialogs
-and accelerator keys -- these are the keyboard combinations which
-are used as shortcuts for menu items.
-Ctrl+F brings up a Find dialog to search for a given symbol. Ctrl+Q quits.
-
-## 3.3 Dragdrop
-This shows how to support drag and drop functionality by handling the WM_DROPFILES message.
-
-## 3.4 Pong
-This is a small and not very well written example of how you might go about
-writing games. It's just a silly little pong game but shows the basic idea.
-
-# 4. Notes
-Requires CFFI. Developed on Windows 8.1 and Windows 7 but should work on
-basically any version because all the APIs are pretty stable and haven't changed
-for a long time.
-
-Licensed under the terms of the MIT license.
-
-Frank James
-October 2016.
-
-
-
-
-
+
+# FTW - Common Lisp For the Win(32) 
+
+# 1. Introduction 
+This library provides a very thin interface to the underlying
+APIs for writing native Windows GUIs in Common Lisp.
+
+The intention is to be able to write the same sort of codes in Lisp as you
+would if writing normal Win32 GUIs in C. This also opens the possibility
+for writing other more generate graphical applications like games.
+
+# 2. Functions
+All underlying Win32 functions have Lisp equivalents, mostly with CamelCase replaced with the Lisp style kebab-case.
+
+Because this is a very thin wrapper over the top of the underlying Win32 API,
+it is assumed the user is at least familiar with the equivalent C programming.
+Documentation for each of the functions can be found on MSDN or any of
+the other C language resource.
+
+## 2.1 Limitations
+Several functions accept IDs for so called "resources", which normally get linked
+in with the object code by the resource compiler (when writing in C). For
+obviously reasons this is not possible when using Lisp.
+
+## 2.2 Lispy CLOS based interface
+It would be nice to have a more Lispy CLOS based interface where you
+can define classes, methods etc. This should be provided by a higher level
+library and does not belong here.
+
+## 2.3 Other platforms
+This is a Windows only library and does not work on any other platform.
+It is not a cross platform GUI library.
+
+# 3. Examples
+Various examples are provided which show various levels of abstractions and a
+good showcase of how to use it.
+
+## 3.1 Zetcode samples
+The rather comprehensive tutorial for the C programming language can be
+found here [zetcode website](http://zetcode.com/gui/winapi/).
+These have been translated to Lisp and show that the same GUIs can be written
+which correspond to largely the same structure.
+
+## 3.2 Climage
+This example GUI displays a two list boxes which show the packages and
+exported symbols. Clicking on a symbol displays the documentation for it.
+
+In addition, this GUI shows how to write and handle modal dialogs
+and accelerator keys -- these are the keyboard combinations which
+are used as shortcuts for menu items.
+Ctrl+F brings up a Find dialog to search for a given symbol. Ctrl+Q quits.
+
+## 3.3 Dragdrop
+This shows how to support drag and drop functionality by handling the WM_DROPFILES message.
+
+## 3.4 Pong
+This is a small and not very well written example of how you might go about
+writing games. It's just a silly little pong game but shows the basic idea.
+
+# 4. Notes
+Requires CFFI. Developed on Windows 8.1 and Windows 7 but should work on
+basically any version because all the APIs are pretty stable and haven't changed
+for a long time.
+
+Licensed under the terms of the MIT license.
+
+Frank James
+October 2016.
+
+
+
+
+
diff --git a/examples/dragdrop/dragdrop.lisp b/examples/dragdrop/dragdrop.lisp
index d63d3dd..ad030ac 100644
--- a/examples/dragdrop/dragdrop.lisp
+++ b/examples/dragdrop/dragdrop.lisp
@@ -1,67 +1,67 @@
-
-
-(defpackage #:ftw.dragdrop
-  (:use #:cl #:cffi #:ftw))
-
-(in-package #:ftw.dragdrop)
-
-;;; We define an empty gui and wait for wm_dropfiles message.
-;;; When we receive it we issue a messagebox to display them
-
-(defwndproc dragdrop-wndproc (hwnd msg wparam lparam)
-  (switch msg
-    ((const +wm-create+)
-     (drag-accept-files hwnd t))
-    ((const +wm-dropfiles+)
-     (let ((hdrop (make-pointer wparam)))
-       (message-box :hwnd hwnd
-                    :text (format nil "Files:~%~{~A~%~}~%" (drag-query-files hdrop))
-                    :caption "Dragged files?")))
-    ((const +wm-destroy+)
-     (drag-accept-files hwnd nil)
-     (post-quit-message)))
-  (default-window-proc hwnd msg wparam lparam))
-
-
-(defun dragdrop ()
-  (default-message-loop (callback dragdrop-wndproc)
-      :class-name "FTW_DRAGDROP"
-      :title "Drag and drop"
-      :width 500 :height 400))
-
-;; ----------- TODO -----------------------
-
-(defcfun (%open-clipboard "OpenClipboard" :convention :stdcall)
-    :boolean
-  (hwnd :pointer))
-
-(defun open-clipboard (&optional hwnd)
-  (%open-clipboard (or hwnd (null-pointer))))
-
-(defcfun (%close-clipboard "CloseClipboard" :convention :stdcall)
-    :boolean)
-
-(defun close-clipboard ()
-  (%close-clipboard))
-
-(defcfun (%get-clipboard-data "GetClipboardData" :convention :stdcall)
-    :pointer
-  (format :uint32))
-
-(defun get-clipboard-data (format)
-  (%get-clipboard-data format))
-
-(defcfun (%empty-clipboard "EmptyClipboard" :convention :stdcall)
-    :boolean)
-
-(defun empty-clipboard ()
-  (%empty-clipboard))
-
-(defcfun (%set-clipboard-data "SetClipboardData" :convention :stdcall)
-    :boolean
-  (format :uint32)
-  (mem :pointer))
-
-(defun set-clipboard-format (format mem)
-  (%set-clipboard-data format mem))
-
+
+
+(defpackage #:ftw.dragdrop
+  (:use #:cl #:cffi #:ftw))
+
+(in-package #:ftw.dragdrop)
+
+;;; We define an empty gui and wait for wm_dropfiles message.
+;;; When we receive it we issue a messagebox to display them
+
+(defwndproc dragdrop-wndproc (hwnd msg wparam lparam)
+  (switch msg
+    ((const +wm-create+)
+     (drag-accept-files hwnd t))
+    ((const +wm-dropfiles+)
+     (let ((hdrop (make-pointer wparam)))
+       (message-box :hwnd hwnd
+                    :text (format nil "Files:~%~{~A~%~}~%" (drag-query-files hdrop))
+                    :caption "Dragged files?")))
+    ((const +wm-destroy+)
+     (drag-accept-files hwnd nil)
+     (post-quit-message)))
+  (default-window-proc hwnd msg wparam lparam))
+
+
+(defun dragdrop ()
+  (default-message-loop (callback dragdrop-wndproc)
+      :class-name "FTW_DRAGDROP"
+      :title "Drag and drop"
+      :width 500 :height 400))
+
+;; ----------- TODO -----------------------
+
+(defcfun (%open-clipboard "OpenClipboard" :convention :stdcall)
+    :boolean
+  (hwnd :pointer))
+
+(defun open-clipboard (&optional hwnd)
+  (%open-clipboard (or hwnd (null-pointer))))
+
+(defcfun (%close-clipboard "CloseClipboard" :convention :stdcall)
+    :boolean)
+
+(defun close-clipboard ()
+  (%close-clipboard))
+
+(defcfun (%get-clipboard-data "GetClipboardData" :convention :stdcall)
+    :pointer
+  (format :uint32))
+
+(defun get-clipboard-data (format)
+  (%get-clipboard-data format))
+
+(defcfun (%empty-clipboard "EmptyClipboard" :convention :stdcall)
+    :boolean)
+
+(defun empty-clipboard ()
+  (%empty-clipboard))
+
+(defcfun (%set-clipboard-data "SetClipboardData" :convention :stdcall)
+    :boolean
+  (format :uint32)
+  (mem :pointer))
+
+(defun set-clipboard-format (format mem)
+  (%set-clipboard-data format mem))
+
diff --git a/examples/icon/icon.lisp b/examples/icon/icon.lisp
new file mode 100644
index 0000000..b31c4cc
--- /dev/null
+++ b/examples/icon/icon.lisp
@@ -0,0 +1,113 @@
+
+(defpackage #:ftw.icon
+  (:use #:cl #:cffi #:ftw))
+
+(in-package #:ftw.icon)
+
+;;; This file shows how to create a custom icon.
+;;; It creates a new icon in the WM_CREATE handler and sets it as the icon for
+;;; the window class using SET-CLASS-POINTER. 
+
+;; This is the "ying" symbol taken from MSDN 
+;; https://msdn.microsoft.com/en-gb/library/windows/desktop/ms648051(v=vs.85).aspx#_win32_Creating_an_Icon
+(defvar *test-icon* nil)
+
+(defun test-create-icon ()
+  (unless *test-icon* 
+    (setf *test-icon*
+	  (create-icon #(#xFF #xFF #xFF #xFF 
+			 #xFF #xFF #xC3 #xFF   
+			 #xFF #xFF #x00 #xFF   
+			 #xFF #xFE #x00 #x7F   
+			 
+			 #xFF #xFC #x00 #x1F   
+			 #xFF #xF8 #x00 #x0F   
+			 #xFF #xF8 #x00 #x0F   
+			 #xFF #xF0 #x00 #x07   
+			 
+			 #xFF #xF0 #x00 #x03   
+			 #xFF #xE0 #x00 #x03   
+			 #xFF #xE0 #x00 #x01   
+			 #xFF #xE0 #x00 #x01   
+			 
+			 #xFF #xF0 #x00 #x01   
+			 #xFF #xF0 #x00 #x00   
+			 #xFF #xF8 #x00 #x00   
+			 #xFF #xFC #x00 #x00   
+			 
+			 #xFF #xFF #x00 #x00   
+			 #xFF #xFF #x80 #x00   
+			 #xFF #xFF #xE0 #x00   
+			 #xFF #xFF #xE0 #x01   
+			 
+			 #xFF #xFF #xF0 #x01   
+			 #xFF #xFF #xF0 #x01   
+			 #xFF #xFF #xF0 #x03   
+			 #xFF #xFF #xE0 #x03   
+			 
+			 #xFF #xFF #xE0 #x07   
+			 #xFF #xFF #xC0 #x0F   
+			 #xFF #xFF #xC0 #x0F   
+			 #xFF #xFF #x80 #x1F   
+			 
+			 #xFF #xFF #x00 #x7F   
+			 #xFF #xFC #x00 #xFF   
+			 #xFF #xF8 #x03 #xFF   
+			 #xFF #xFC #x3F #xFF)
+		       #(#x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x38 #x00   
+			 
+			 #x00 #x00 #x7C #x00   
+			 #x00 #x00 #x7C #x00   
+			 #x00 #x00 #x7C #x00   
+			 #x00 #x00 #x38 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00   
+			 #x00 #x00 #x00 #x00)
+		       :bits-per-pixel 1)))
+  *test-icon*)
+
+(defwndproc test-icon-wndproc (hwnd msg wparam lparam)
+  (switch msg
+    ((const +wm-create+)
+     (set-class-pointer hwnd :icon (test-create-icon)))
+    ((const +wm-destroy+)
+     (destroy-icon *test-icon*)
+     (setf *test-icon* nil)
+     (post-quit-message)))
+  (default-window-proc hwnd msg wparam lparam))
+
+(defun test-icon ()
+  (default-message-loop (callback test-icon-wndproc) 
+      :class-name "TEST_ICON" 
+      :title "Test icon" ))
+
diff --git a/examples/pong/pong.lisp b/examples/pong/pong.lisp
index a34364b..32b93bd 100644
--- a/examples/pong/pong.lisp
+++ b/examples/pong/pong.lisp
@@ -1,230 +1,230 @@
-
-(defpackage #:ftw.pong
-  (:use #:cl #:cffi #:ftw))
-
-(in-package #:ftw.pong)
-
-;;; This file should define a simple pong type game.
-;;; It needs to do the following:
-;;; - run a timer, on each tick update the screen i.e. repaint
-;;; - intercept keystrokes to for up and down keys
-
-(defparameter *timestep* 1.0)
-(defparameter *friction* -0.01)
-(defparameter *pad-height* 0.2)
-(defparameter *pad-width* 0.05)
-(defparameter *pad-height-phys* 50)
-(defparameter *pad-width-phys* 25)
-(defparameter *ball-width* 0.05)
-(defparameter *ball-width-phys* 15)
-
-(defstruct pos
-  (x 0)
-  (y 0)
-  (vx 0)
-  (vy 0)
-  (ax *friction*)
-  (ay *friction*))
-
-;; x'' = a
-;; x' = at (v0 = 0)
-;; x = at^2/2 (x0 = 0)
-(defun update-pos (p)
-  (incf (pos-x p) (* *timestep* (pos-vx p)))
-  (incf (pos-y p) (* *timestep* (pos-vy p)))
-  (incf (pos-vx p) (* *timestep* (pos-vx p) (pos-ax p)))
-  (incf (pos-vy p) (* *timestep* (pos-vy p) (pos-ay p))))
-  
-
-(defparameter *phys-x* 300)
-(defparameter *phys-y* 300)
-(defparameter *log-x* 1.0)
-(defparameter *log-y* 1.0)
-
-(defun pos-physical (p) 
-  (make-pos :x (truncate (* (pos-x p) (/ *phys-x* *log-x*)))
-	    :y (truncate (* (pos-y p) (/ *phys-y* *log-y*)))
-	    :vx (truncate (* (pos-vx p) (/ *phys-x* *log-x*)))
-	    :vy (truncate (* (pos-vy p) (/ *phys-y* *log-y*)))))
-
-
-(defparameter *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*))
-(defparameter *p2* (make-pos :x 0.8 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*))
-(defparameter *ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0))
-
-(defun reset-game ()
-  (setf *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)
-	*p2* (make-pos :x 0.9 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)
-	*ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0)))
-
-(defun update-game ()
-  (let ((items (list *p1* *p2* *ball*)))
-    ;; update all positions
-    (dolist (item items)
-      (update-pos item))
-
-    (when (< (pos-y *p2*) (pos-y *ball*))
-      (setf (pos-vy *p2*) 0.005))
-    (when (> (pos-y *p2*) (pos-y *ball*))
-      (setf (pos-vy *p2*) -0.005))
-    
-    ;; detect collisions -- disallow p1 and p2 from going outside screen
-    ;; and invert velicity of ball if contacts p1 or p2
-    (dolist (p (list *p1* *p2*))
-      (when (> (+ (pos-y p) *pad-height*) *log-y*)
-	(setf (pos-y p) (- *log-y* *pad-height*)
-	      (pos-vy p) 0))
-      (when (< (pos-y p) 0)
-	(setf (pos-y p) 0
-	      (pos-vy p) 0))
-
-      (when (and (>= (+ (pos-x *ball*) *ball-width*)
-		     (pos-x p))
-		 (<= (pos-x *ball*) 
-		     (+ (pos-x p) *pad-width*))
-		 (>= (+ (pos-y *ball*) *ball-width*)
-		     (pos-y p))
-		 (<= (pos-y *ball*)
-		     (+ (pos-y p) *pad-height*)))
-
-        (let* ((dy (- (/ (- (+ (pos-y p) *pad-height*)
-                            (+ (pos-y *ball*) *ball-width*))
-                         *pad-height*)
-                      0.5))
-               (fx (cos dy))
-               (fy (sin dy))
-               (f (sqrt (+ (* fx fx) (* fy fy)))))
-          ;; adjust velocities
-          ;; FIXME: this needs touching up because the mechanics aren't right,
-          ;; ball behaves strangely 
-          (setf (pos-vx *ball*)
-                (- (* (pos-vx *ball*) (/ fx f)))
-                (pos-x *ball*)
-                (if (< (pos-x *ball*) 0.5)
-                    (+ (pos-x p) *ball-width*)
-                    (- (pos-x p) *ball-width*))
-                                    
-                (pos-vy *ball*)
-                (+ (pos-vy *ball*)
-                   (* (cond
-                        ((> (pos-y p) 0.6) -1)
-                        ((< (pos-y p) 0.4) -1)
-                        (t 1))
-                      (/ fy f)
-                      (sqrt (+ (* (pos-vx *ball*) (pos-vx *ball*))
-                               (* (pos-vy *ball*) (pos-vy *ball*))))))))))
-
-    (when (or (> (pos-x *ball*) *log-x*)
-	      (< (pos-x *ball*) 0)
-	      (> (pos-y *ball*) *log-y*)
-	      (< (pos-y *ball*) 0))
-      (reset-game))))
-
-
-
-(defun pong-create (hwnd)
-  ;; initialize the client area ... we don't have any extra controls just yet 
-  ;; we could add a static for player scores ... but not done that yet
-  
-  ;; set the timer to start ticking 
-  (set-timer :hwnd hwnd :elapse 5 :replace-timer 1)
-  
-  nil)
-
-(defun pong-paint (hwnd)
-  ;; repaint the client area
-  (with-paint (hwnd hdc)
-    ;; paint rectangles, line and ball
-    (let* ((black (get-stock-object :black-brush))
-	   (white (get-stock-object :white-brush))
-	   (hold-brush (select-object hdc black)))
-      (select-object hdc white)
-
-      (let ((p (pos-physical *p1*)))
-	(rectangle hdc (pos-x p) (pos-y p)
-		   (+ (pos-x p) *pad-width-phys*)
-		   (+ (pos-y p) *pad-height-phys*)))
-      (let ((p (pos-physical *p2*)))
-	(rectangle hdc (pos-x p) (pos-y p)
-		   (+ (pos-x p) *pad-width-phys*)
-		   (+ (pos-y p) *pad-height-phys*)))      
-
-      (let* ((pen (get-stock-object :white-pen))
-	     (hold-pen (select-object hdc pen)))
-	(move-to hdc (truncate *phys-x* 2) 0)
-	(line-to hdc (truncate *phys-x* 2) *phys-y*)
-
-	(move-to hdc 0 0)
-	(line-to hdc *phys-x* 0)
-	(line-to hdc *phys-x* *phys-y*)
-	(line-to hdc 0 *phys-y*)
-	(line-to hdc 0 0)
-
-	(select-object hdc hold-pen))
-      
-      (let ((p (pos-physical *ball*)))
-	(ellipse hdc (pos-x p) (pos-y p)
-		 (+ (pos-x p) *ball-width-phys*)
-		 (+ (pos-y p) *ball-width-phys*)))
-      
-      (select-object hdc hold-brush))))
-
-(defun pong-timer (hwnd)
-  (update-game)  
-  (invalidate-rect hwnd nil t))
-
-(defun pong-keydown (hwnd wparam)
-  (let ((key (virtual-code-key wparam)))
-    (case key
-      (:up (setf (pos-vy *p1*) -0.005))
-      (:down (setf (pos-vy *p1*) 0.005))
-      (:keyr ;; reset game
-       (reset-game))
-      (:keyq ;; quit
-       (destroy-window hwnd))
-      (:keyh ;; help
-       (message-box :hwnd hwnd
-                    :text "
-Simple pong game. 
-Up/down       move paddle
-R             reset game
-Q             quit
-"
-                    :caption "Help"
-                    :icon :information)))))
-
-(defwndproc pong-wndproc (hwnd msg wparam lparam)
-  (switch msg
-    ((const +wm-create+)
-     (pong-create hwnd))
-    ((const +wm-paint+)
-     (pong-paint hwnd))
-    ((const +wm-timer+)
-     (pong-timer hwnd))
-    ((const +wm-keydown+)
-     (pong-keydown hwnd wparam))
-    ((const +wm-destroy+)
-     (post-quit-message)))
-  (default-window-proc hwnd msg wparam lparam))
-
-
-    
-(defun pong ()
-  (register-class "PONG" (callback pong-wndproc)
-                  :cursor (load-cursor :arrow)
-                  :background (get-stock-object :black-brush))
-  (let ((hwnd (create-window "PONG"
-                             :window-name "Pong"
-                             :styles (logior-consts +ws-overlappedwindow+ +ws-visible+)
-                             :x 100 :y 100 :width 400 :height 300))
-        (msg (make-msg)))
-    (show-window hwnd)
-    (update-window hwnd)
-    (do ((done nil))
-        (done)
-      (let ((r (get-message msg)))
-        (cond
-          ((zerop r) (setf done t))
-          (t
-           (translate-message msg)
-           (dispatch-message msg)))))))
+
+(defpackage #:ftw.pong
+  (:use #:cl #:cffi #:ftw))
+
+(in-package #:ftw.pong)
+
+;;; This file should define a simple pong type game.
+;;; It needs to do the following:
+;;; - run a timer, on each tick update the screen i.e. repaint
+;;; - intercept keystrokes to for up and down keys
+
+(defparameter *timestep* 1.0)
+(defparameter *friction* -0.01)
+(defparameter *pad-height* 0.2)
+(defparameter *pad-width* 0.05)
+(defparameter *pad-height-phys* 50)
+(defparameter *pad-width-phys* 25)
+(defparameter *ball-width* 0.05)
+(defparameter *ball-width-phys* 15)
+
+(defstruct pos
+  (x 0)
+  (y 0)
+  (vx 0)
+  (vy 0)
+  (ax *friction*)
+  (ay *friction*))
+
+;; x'' = a
+;; x' = at (v0 = 0)
+;; x = at^2/2 (x0 = 0)
+(defun update-pos (p)
+  (incf (pos-x p) (* *timestep* (pos-vx p)))
+  (incf (pos-y p) (* *timestep* (pos-vy p)))
+  (incf (pos-vx p) (* *timestep* (pos-vx p) (pos-ax p)))
+  (incf (pos-vy p) (* *timestep* (pos-vy p) (pos-ay p))))
+  
+
+(defparameter *phys-x* 300)
+(defparameter *phys-y* 300)
+(defparameter *log-x* 1.0)
+(defparameter *log-y* 1.0)
+
+(defun pos-physical (p) 
+  (make-pos :x (truncate (* (pos-x p) (/ *phys-x* *log-x*)))
+	    :y (truncate (* (pos-y p) (/ *phys-y* *log-y*)))
+	    :vx (truncate (* (pos-vx p) (/ *phys-x* *log-x*)))
+	    :vy (truncate (* (pos-vy p) (/ *phys-y* *log-y*)))))
+
+
+(defparameter *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*))
+(defparameter *p2* (make-pos :x 0.8 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*))
+(defparameter *ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0))
+
+(defun reset-game ()
+  (setf *p1* (make-pos :x 0.1 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)
+	*p2* (make-pos :x 0.9 :y 0.5 :vx 0 :vy 0 :ax *friction* :ay *friction*)
+	*ball* (make-pos :x 0.5 :y 0.5 :vx 0.01 :y 0 :ax 0 :ay 0)))
+
+(defun update-game ()
+  (let ((items (list *p1* *p2* *ball*)))
+    ;; update all positions
+    (dolist (item items)
+      (update-pos item))
+
+    (when (< (pos-y *p2*) (pos-y *ball*))
+      (setf (pos-vy *p2*) 0.005))
+    (when (> (pos-y *p2*) (pos-y *ball*))
+      (setf (pos-vy *p2*) -0.005))
+    
+    ;; detect collisions -- disallow p1 and p2 from going outside screen
+    ;; and invert velicity of ball if contacts p1 or p2
+    (dolist (p (list *p1* *p2*))
+      (when (> (+ (pos-y p) *pad-height*) *log-y*)
+	(setf (pos-y p) (- *log-y* *pad-height*)
+	      (pos-vy p) 0))
+      (when (< (pos-y p) 0)
+	(setf (pos-y p) 0
+	      (pos-vy p) 0))
+
+      (when (and (>= (+ (pos-x *ball*) *ball-width*)
+		     (pos-x p))
+		 (<= (pos-x *ball*) 
+		     (+ (pos-x p) *pad-width*))
+		 (>= (+ (pos-y *ball*) *ball-width*)
+		     (pos-y p))
+		 (<= (pos-y *ball*)
+		     (+ (pos-y p) *pad-height*)))
+
+        (let* ((dy (- (/ (- (+ (pos-y p) *pad-height*)
+                            (+ (pos-y *ball*) *ball-width*))
+                         *pad-height*)
+                      0.5))
+               (fx (cos dy))
+               (fy (sin dy))
+               (f (sqrt (+ (* fx fx) (* fy fy)))))
+          ;; adjust velocities
+          ;; FIXME: this needs touching up because the mechanics aren't right,
+          ;; ball behaves strangely 
+          (setf (pos-vx *ball*)
+                (- (* (pos-vx *ball*) (/ fx f)))
+                (pos-x *ball*)
+                (if (< (pos-x *ball*) 0.5)
+                    (+ (pos-x p) *ball-width*)
+                    (- (pos-x p) *ball-width*))
+                                    
+                (pos-vy *ball*)
+                (+ (pos-vy *ball*)
+                   (* (cond
+                        ((> (pos-y p) 0.6) -1)
+                        ((< (pos-y p) 0.4) -1)
+                        (t 1))
+                      (/ fy f)
+                      (sqrt (+ (* (pos-vx *ball*) (pos-vx *ball*))
+                               (* (pos-vy *ball*) (pos-vy *ball*))))))))))
+
+    (when (or (> (pos-x *ball*) *log-x*)
+	      (< (pos-x *ball*) 0)
+	      (> (pos-y *ball*) *log-y*)
+	      (< (pos-y *ball*) 0))
+      (reset-game))))
+
+
+
+(defun pong-create (hwnd)
+  ;; initialize the client area ... we don't have any extra controls just yet 
+  ;; we could add a static for player scores ... but not done that yet
+  
+  ;; set the timer to start ticking 
+  (set-timer :hwnd hwnd :elapse 5 :replace-timer 1)
+  
+  nil)
+
+(defun pong-paint (hwnd)
+  ;; repaint the client area
+  (with-paint (hwnd hdc)
+    ;; paint rectangles, line and ball
+    (let* ((black (get-stock-object :black-brush))
+	   (white (get-stock-object :white-brush))
+	   (hold-brush (select-object hdc black)))
+      (select-object hdc white)
+
+      (let ((p (pos-physical *p1*)))
+	(rectangle hdc (pos-x p) (pos-y p)
+		   (+ (pos-x p) *pad-width-phys*)
+		   (+ (pos-y p) *pad-height-phys*)))
+      (let ((p (pos-physical *p2*)))
+	(rectangle hdc (pos-x p) (pos-y p)
+		   (+ (pos-x p) *pad-width-phys*)
+		   (+ (pos-y p) *pad-height-phys*)))      
+
+      (let* ((pen (get-stock-object :white-pen))
+	     (hold-pen (select-object hdc pen)))
+	(move-to hdc (truncate *phys-x* 2) 0)
+	(line-to hdc (truncate *phys-x* 2) *phys-y*)
+
+	(move-to hdc 0 0)
+	(line-to hdc *phys-x* 0)
+	(line-to hdc *phys-x* *phys-y*)
+	(line-to hdc 0 *phys-y*)
+	(line-to hdc 0 0)
+
+	(select-object hdc hold-pen))
+      
+      (let ((p (pos-physical *ball*)))
+	(ellipse hdc (pos-x p) (pos-y p)
+		 (+ (pos-x p) *ball-width-phys*)
+		 (+ (pos-y p) *ball-width-phys*)))
+      
+      (select-object hdc hold-brush))))
+
+(defun pong-timer (hwnd)
+  (update-game)  
+  (invalidate-rect hwnd nil t))
+
+(defun pong-keydown (hwnd wparam)
+  (let ((key (virtual-code-key wparam)))
+    (case key
+      (:up (setf (pos-vy *p1*) -0.005))
+      (:down (setf (pos-vy *p1*) 0.005))
+      (:keyr ;; reset game
+       (reset-game))
+      (:keyq ;; quit
+       (destroy-window hwnd))
+      (:keyh ;; help
+       (message-box :hwnd hwnd
+                    :text "
+Simple pong game. 
+Up/down       move paddle
+R             reset game
+Q             quit
+"
+                    :caption "Help"
+                    :icon :information)))))
+
+(defwndproc pong-wndproc (hwnd msg wparam lparam)
+  (switch msg
+    ((const +wm-create+)
+     (pong-create hwnd))
+    ((const +wm-paint+)
+     (pong-paint hwnd))
+    ((const +wm-timer+)
+     (pong-timer hwnd))
+    ((const +wm-keydown+)
+     (pong-keydown hwnd wparam))
+    ((const +wm-destroy+)
+     (post-quit-message)))
+  (default-window-proc hwnd msg wparam lparam))
+
+
+    
+(defun pong ()
+  (register-class "PONG" (callback pong-wndproc)
+                  :cursor (load-cursor :arrow)
+                  :background (get-stock-object :black-brush))
+  (let ((hwnd (create-window "PONG"
+                             :window-name "Pong"
+                             :styles (logior-consts +ws-overlappedwindow+ +ws-visible+)
+                             :x 100 :y 100 :width 400 :height 300))
+        (msg (make-msg)))
+    (show-window hwnd)
+    (update-window hwnd)
+    (do ((done nil))
+        (done)
+      (let ((r (get-message msg)))
+        (cond
+          ((zerop r) (setf done t))
+          (t
+           (translate-message msg)
+           (dispatch-message msg)))))))
diff --git a/ffi.lisp b/ffi.lisp
index c36126d..3ae50dd 100644
--- a/ffi.lisp
+++ b/ffi.lisp
@@ -2459,7 +2459,10 @@ Return is keywork specifying button user clicked."
   (with-foreign-object (bp :uint8 (length data))
     (dotimes (i (length data))
       (setf (mem-aref bp :uint8 i) (aref data i)))
-    (%create-bitmap width height planes bits-per-pixel bp)))
+    (%create-bitmap (truncate width 8) (truncate height 8)
+		    planes
+		    bits-per-pixel
+		    bp)))
 
 (defcfun (%get-window-text-length "GetWindowTextLengthW" :convention :stdcall)
     :int32 
@@ -3970,3 +3973,98 @@ Return is keywork specifying button user clicked."
 (defun reply-message (lresult)
   (%reply-message lresult))
 
+(defcfun (%create-icon "CreateIcon" :convention :stdcall)
+    :pointer
+  (instance :pointer)
+  (width :int32)
+  (height :int32)
+  (planes :uint8)
+  (bits-per-pixel :uint8)
+  (and-bits :pointer)
+  (xor-bits :pointer))
+
+(defun create-icon (and-bits xor-bits &key instance bits-per-pixel)
+  (unless bits-per-pixel (setf bits-per-pixel 8))
+
+  (let ((width (get-system-metrics :cx-icon))
+	(height (get-system-metrics :cy-icon)))
+    (unless (= (length and-bits) (truncate (* width height bits-per-pixel) 8))
+      (error "and-bits needs to be ~S wide (is only ~S)" 
+	     (truncate (* width height bits-per-pixel) 8)
+	     (length and-bits)))
+    (unless (= (length xor-bits) (length and-bits))
+      (error "bitmasks need to be same length"))
+
+    (with-foreign-object (abits :uint8 (length and-bits))
+      (with-foreign-object (xbits :uint8 (length and-bits))
+	(dotimes (i (length and-bits))
+	  (setf (mem-aref abits :uint8 i) (aref and-bits i)
+		(mem-aref xbits :uint8 i) (aref xor-bits i)))
+	(let ((icon (%create-icon (or instance (get-module-handle))
+				  width
+				  height
+				  1
+				  bits-per-pixel
+				  abits
+				  xbits)))
+	  (if (null-pointer-p icon)
+	      (get-last-error)
+	      icon))))))
+
+(defcfun (%destroy-icon "DestroyIcon" :convention :stdcall)
+    :boolean
+  (icon :pointer))
+
+(defun destroy-icon (icon)
+  (%destroy-icon icon))
+
+(defcfun (%draw-icon "DrawIcon" :convention :stdcall)
+    :boolean
+  (hdc :pointer)
+  (x :int32)
+  (y :int32)
+  (icon :pointer))
+
+(defun draw-icon (hdc x y icon)
+  (%draw-icon hdc x y icon))
+
+
+(defcfun (%get-device-caps "GetDeviceCaps" :convention :stdcall)
+    :int32
+  (hdc :pointer)
+  (index :int32))
+
+(defun get-device-caps (hdc name)
+  (%get-device-caps hdc 
+		    (if (keywordp name)
+			(ecase name 
+			  (:driver-version 0)
+			  (:technology 2)
+			  (:hsize-mm 4)
+			  (:vsize-mm 6)
+			  (:hsize-pixel 8)
+			  (:vsize-pixel 10)
+			  (:bits-per-pixel 12)
+			  (:planes 14)
+			  (:numbrushes 16)
+			  (:numpens 18)
+			  (:nummarkers 20)
+			  (:numfonts 22)
+			  (:numcolors 24)
+			  (:pdevicesize 26)
+			  (:curvecaps 28)
+			  (:linecaps 30)
+			  (:polygonalcaps 32)
+			  (:textcaps 34)
+			  (:clipcaps 36)
+			  (:rastercaps 38)
+			  (:aspectx 40)
+			  (:aspecty 42)
+			  (:aspectxy 44)
+			  (:logpixelsx 88)
+			  (:logpixelsy 90)
+			  (:sizepalette 104)
+			  (:numreserved 106)
+			  (:colorres 108))
+			name)))
+
diff --git a/ftw.lisp b/ftw.lisp
index e7a1739..4e8e20c 100644
--- a/ftw.lisp
+++ b/ftw.lisp
@@ -1,39 +1,45 @@
-
-;;; This file defines a CLOS based layer to simplify defining and working 
-;;; with gui elements. 
-
-(in-package #:ftw)
-
-(defun set-default-font (hwnd &optional font)
-  (send-message hwnd (const +wm-setfont+) :wparam (or font (get-stock-object :default-gui-font))))
-
-(defun default-message-loop (wndproc &key class-name title width height)
-  (let ((cname (or class-name "FTW_MAIN_CLASS")))
-    (register-class cname 
-                    wndproc 
-                    :cursor (load-cursor :arrow)
-                    :background (get-sys-color-brush :3d-face))
-    (let ((hwnd (create-window cname 
-                               :window-name (or title cname)
-                               :styles (logior-consts +ws-overlappedwindow+ +ws-visible+)
-                               :x 100 :y 100 :width (or width 400) :height (or height 300)))
-          (msg (make-msg)))
-      (unless hwnd (return-from default-message-loop nil))
-      
-      (show-window hwnd)
-      (update-window hwnd)
-      (do ((done nil))
-          (done)
-        (let ((r (get-message msg)))
-          (cond
-            ((zerop r) (setf done t))
-            (t
-             (translate-message msg)
-             (dispatch-message msg))))))))
-
-
-(defun message-poll (&optional timeout)
-  (msg-wait-for-multiple-objects :timeout timeout
-                                 :mask (logior-consts +qs-allevents+)))
-
-
+
+;;; This file defines useful utility functions and macros to simplify some common tasks.
+
+(in-package #:ftw)
+
+(defun set-default-font (hwnd &optional font)
+  "Send a WM_SETFONT message to the window with the specified font or default GUI font." 
+  (send-message hwnd (const +wm-setfont+) :wparam (or font (get-stock-object :default-gui-font))))
+
+(defun default-message-loop (wndproc &key class-name title width height)
+  "Standard message loop. Defines a new window class with :arrow cursor and 3d-face background,
+creates an overlapped, visible  window of this class. Shows, updates and sets this window to 
+the foreground. Then loops, processing messages, until a WM_QUIT message is received.
+" 
+  (let ((cname (or class-name "FTW_MAIN_CLASS")))
+    (register-class cname 
+                    wndproc 
+                    :cursor (load-cursor :arrow)
+                    :background (get-sys-color-brush :3d-face))
+    (let ((hwnd (create-window cname 
+                               :window-name (or title cname)
+                               :styles (logior-consts +ws-overlappedwindow+ +ws-visible+)
+                               :x 100 :y 100 :width (or width 400) :height (or height 300)))
+          (msg (make-msg)))
+      (unless hwnd (return-from default-message-loop nil))
+      
+      (show-window hwnd)
+      (update-window hwnd)
+      (set-foreground-window hwnd)
+      (do ((done nil))
+          (done)
+        (let ((r (get-message msg)))
+          (cond
+            ((zerop r) (setf done t))
+            (t
+             (translate-message msg)
+             (dispatch-message msg))))))))
+
+
+(defun message-poll (&optional timeout)
+  "Wait for messages to be available in the message queue." 
+  (msg-wait-for-multiple-objects :timeout timeout
+                                 :mask (logior-consts +qs-allevents+)))
+
+
diff --git a/package.lisp b/package.lisp
index 8570742..b11045c 100644
--- a/package.lisp
+++ b/package.lisp
@@ -302,7 +302,12 @@
        #:drag-query-point
        #:broadcast-system-message
        #:reply-message
-       
+       #:create-icon
+       #:destroy-icon
+       #:draw-icon
+       #:get-device-caps
+
+
 	   ;; ftw.lisp 
 	   #:set-default-font 
 	   #:default-message-loop