84 lines
2.9 KiB
Plaintext
84 lines
2.9 KiB
Plaintext
;; @module win32demo.lsp
|
|
;; @description Event loop demo
|
|
;; @author Cyril Slobin
|
|
;; @location http://slobin.pp.ru/newlisp/win32demo.lsp
|
|
;; @version $Id: win32demo.lsp,v 1.4 2010/06/10 02:14:08 slobin Exp $
|
|
|
|
; see also: http://slobin.livejournal.com/339071.html ; added by LM
|
|
|
|
(println "win32demo")
|
|
|
|
(define (import-list library flist)
|
|
(dolist (fname flist) (import library (string fname))))
|
|
|
|
(define-macro (@setq %var %value)
|
|
(set %var (eval %value))
|
|
(println %var " " (eval %var)))
|
|
|
|
(import-list "kernel32" '(GetModuleHandleA GetConsoleWindow))
|
|
(import-list "user32" '(PostQuitMessage DefWindowProcA))
|
|
(import-list "user32" '(LoadCursorA RegisterClassA CreateWindowExA))
|
|
(import-list "user32" '(ShowWindow UpdateWindow))
|
|
(import-list "user32" '(GetMessageA TranslateMessage DispatchMessageA))
|
|
|
|
(setq WM_CREATE 1 WM_DESTROY 2 WM_CHAR 0x102 WM_LBUTTONDOWN 0x201)
|
|
(setq IDC_ARROW 0x7F00 CS_VREDRAW 1 CS_HREDRAW 2 COLOR_WINDOW 5)
|
|
(setq WS_OVERLAPPEDWINDOW 0xCF0000 HWND_MESSAGE -3 SW_SHOWDEFAULT 10)
|
|
|
|
(@setq hinstance (GetModuleHandleA 0))
|
|
(@setq hconsole (GetConsoleWindow))
|
|
(@setq cursor (LoadCursorA 0 IDC_ARROW))
|
|
|
|
(define (window-callback-function hwnd message wparam lparam)
|
|
(cond
|
|
((= message WM_CREATE) (println "created") 0)
|
|
((= message WM_LBUTTONDOWN) (println "click!") 0)
|
|
((= message WM_CHAR) (println (format "char %c" wparam)) 0)
|
|
((= message WM_DESTROY) (println "destroyed") (PostQuitMessage 0) 0)
|
|
(true (DefWindowProcA hwnd message wparam lparam))))
|
|
|
|
(setq wndproc (callback 0 'window-callback-function))
|
|
(setq classname "newlisp class")
|
|
|
|
(setq wc (pack (dup "ld" 10)
|
|
(| CS_HREDRAW CS_VREDRAW) ; style
|
|
wndproc ; lpfnWndProc
|
|
0 ; cbClsExtra
|
|
0 ; cbWndExtra
|
|
hinstance ; hInstance
|
|
0 ; hIcon
|
|
cursor ; hCursor
|
|
(+ COLOR_WINDOW 1) ; hbrBackground
|
|
0 ; lpszMenuName
|
|
classname ; lpszClassName
|
|
))
|
|
|
|
(@setq hwc (RegisterClassA wc))
|
|
(@setq hwnd (CreateWindowExA
|
|
0 ; dwExStyle
|
|
"newlisp class" ; lpClassName
|
|
"newlisp window" ; lpWindowName
|
|
WS_OVERLAPPEDWINDOW ; dwStyle
|
|
80 60 640 480 ; x y w h
|
|
0 ; hwndParent
|
|
0 ; hMenu
|
|
hinstance ; hInstance
|
|
0 ; hParam
|
|
))
|
|
|
|
; hconsole and HWND_MESSAGE are other useful values for hwndParent
|
|
|
|
(ShowWindow hwnd SW_SHOWDEFAULT)
|
|
(UpdateWindow hwnd)
|
|
|
|
(setq msg (pack "n28"))
|
|
|
|
(until (member (GetMessageA msg hwnd 0 0) '(0 -1))
|
|
(TranslateMessage msg)
|
|
(DispatchMessageA msg))
|
|
|
|
(println "the end")
|
|
|
|
(exit)
|
|
|