aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

September 2017 Update

Browse source
This commit is contained in:
Ingy döt Net 2017-09-23 10:01:46 +02:00
parent bba7bfd280
commit ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
Download patch file Download diff file Expand all files Collapse all files

34
Task/Window-creation/TXR/window-creation-1.txr Normal file
View file

@ -0,0 +1,34 @@
(defvarl SDL_INIT_VIDEO #x00000020)
(defvarl SDL_SWSURFACE #x00000000)
(defvarl SDL_HWPALETTE #x20000000)
(typedef SDL_Surface (cptr SDL_Surface))
(typedef SDL_EventType (enumed uint8 SDL_EventType
(SDL_KEYUP 3)
(SDL_QUIT 12)))
(typedef SDL_Event (union SD_Event
(type SDL_EventType)
(pad (array 8 uint32))))
(with-dyn-lib "libSDL.so"
(deffi SDL_Init "SDL_Init" int (uint32))
(deffi SDL_SetVideoMode "SDL_SetVideoMode"
SDL_Surface (int int int uint32))
(deffi SDL_GetError "SDL_GetError" str ())
(deffi SDL_WaitEvent "SDL_WaitEvent" int ((ptr-out SDL_Event)))
(deffi SDL_Quit "SDL_Quit" void ()))
(when (neql 0 (SDL_Init SDL_INIT_VIDEO))
(put-string `unable to initialize SDL: @(SDL_GetError)`)
(exit nil))
(unwind-protect
(progn
(SDL_SetVideoMode 800 600 16 (logior SDL_SWSURFACE SDL_HWPALETTE))
(let ((e (make-union (ffi SDL_Event))))
(until* (memql (union-get e 'type) '(SDL_KEYUP SDL_QUIT))
(SDL_WaitEvent e))))
(SDL_Quit))

66
Task/Window-creation/TXR/window-creation-2.txr Normal file
View file

@ -0,0 +1,66 @@
(typedef XID uint32)
(typedef Window XID)
(typedef Drawable XID)
(typedef Display (cptr Display))
(typedef GC (cptr GC))
(typedef XEventType (enum _XEventType
(KeyPress 2)
(Expose 12)))
(defvarl KeyPressMask (ash 1 0))
(defvarl ExposureMask (ash 1 15))
(typedef XEvent (union _XEvent
(type XEventType)
(pad (array 24 long))))
(defvarl NULL cptr-null)
(with-dyn-lib "libX11.so"
(deffi XOpenDisplay "XOpenDisplay" Display (bstr))
(deffi XCloseDisplay "XCloseDisplay" int (Display))
(deffi XDefaultScreen "XDefaultScreen" int (Display))
(deffi XRootWindow "XRootWindow" Window (Display int))
(deffi XBlackPixel "XBlackPixel" ulong (Display int))
(deffi XWhitePixel "XWhitePixel" ulong (Display int))
(deffi XCreateSimpleWindow "XCreateSimpleWindow" Window (Display
Window
int int
uint uint uint
ulong ulong))
(deffi XSelectInput "XSelectInput" int (Display Window long))
(deffi XMapWindow "XMapWindow" int (Display Window))
(deffi XNextEvent "XNextEvent" int (Display (ptr-out XEvent)))
(deffi XDefaultGC "XDefaultGC" GC (Display int))
(deffi XFillRectangle "XFillRectangle" int (Display Drawable GC
int int uint uint))
(deffi XDrawString "XDrawString" int (Display Drawable GC
int int bstr int)))
(let* ((msg "Hello, world!")
(d (XOpenDisplay nil)))
(when (equal d NULL)
(put-line "Cannot-open-display" *stderr*)
(exit 1))
(let* ((s (XDefaultScreen d))
(w (XCreateSimpleWindow d (XRootWindow d s) 10 10 100 100 1
(XBlackPixel d s) (XWhitePixel d s))))
(XSelectInput d w (logior ExposureMask KeyPressMask))
(XMapWindow d w)
(while t
(let ((e (make-union (ffi XEvent))))
(XNextEvent d e)
(caseq (union-get e 'type)
(Expose
(XFillRectangle d w (XDefaultGC d s) 20 20 10 10)
(XDrawString d w (XDefaultGC d s) 10 50 msg (length msg)))
(KeyPress (return)))))
(XCloseDisplay d)))

31
Task/Window-creation/TXR/window-creation-3.txr Normal file
View file

@ -0,0 +1,31 @@
(typedef GtkObject* (cptr GtkObject))
(typedef GtkWidget* (cptr GtkWidget))
(typedef GtkWidget* (cptr GtkWidget))
(typedef GtkWindowType (enum GtkWindowType
GTK_WINDOW_TOPLEVEL
GTK_WINDOW_POPUP))
(with-dyn-lib "libgtk-x11-2.0.so.0"
(deffi gtk_init "gtk_init" void ((ptr int) (ptr (ptr (zarray str)))))
(deffi gtk_window_new "gtk_window_new" GtkWidget* (GtkWindowType))
(deffi gtk_signal_connect_full "gtk_signal_connect_full"
ulong (GtkObject* str closure closure val closure int int))
(deffi gtk_widget_show "gtk_widget_show" void (GtkWidget*))
(deffi gtk_main "gtk_main" void ())
(deffi-sym gtk_main_quit "gtk_main_quit"))
(defmacro GTK_OBJECT (cptr)
^(cptr-cast 'GtkObject ,cptr))
(defmacro gtk_signal_connect (object name func func-data)
^(gtk_signal_connect_full ,object ,name ,func cptr-null
,func-data cptr-null 0 0))
(gtk_init (length *args*) (vec-list *args*))
(let ((window (gtk_window_new 'GTK_WINDOW_TOPLEVEL)))
(gtk_signal_connect (GTK_OBJECT window) "destroy" gtk_main_quit nil)
(gtk_widget_show window)
(gtk_main))

130
Task/Window-creation/TXR/window-creation-4.txr Normal file
View file

@ -0,0 +1,130 @@
(typedef LRESULT int-ptr-t)
(typedef LPARAM int-ptr-t)
(typedef WPARAM uint-ptr-t)
(typedef UINT uint32)
(typedef LONG int32)
(typedef WORD uint16)
(typedef DWORD uint32)
(typedef LPVOID cptr)
(typedef BOOL (bool int32))
(typedef BYTE uint8)
(typedef HWND (cptr HWND))
(typedef HINSTANCE (cptr HINSTANCE))
(typedef HICON (cptr HICON))
(typedef HCURSOR (cptr HCURSOR))
(typedef HBRUSH (cptr HBRUSH))
(typedef HMENU (cptr HMENU))
(typedef HDC (cptr HDC))
(typedef ATOM WORD)
(typedef LPCTSTR wstr)
(defvarl NULL cptr-null)
(typedef WNDCLASS (struct WNDCLASS
(style UINT)
(lpfnWndProc closure)
(cbClsExtra int)
(cbWndExtra int)
(hInstance HINSTANCE)
(hIcon HICON)
(hCursor HCURSOR)
(hbrBackground HBRUSH)
(lpszMenuName LPCTSTR)
(lpszClassName LPCTSTR)))
(defmeth WNDCLASS :init (me)
(zero-fill (ffi WNDCLASS) me))
(typedef POINT (struct POINT
(x LONG)
(y LONG)))
(typedef MSG (struct MSG
(hwnd HWND)
(message UINT)
(wParam WPARAM)
(lParam LPARAM)
(time DWORD)
(pt POINT)))
(typedef RECT (struct RECT
(left LONG)
(top LONG)
(right LONG)
(bottom LONG)))
(typedef PAINTSTRUCT (struct PAINTSTRUCT
(hdc HDC)
(fErase BOOL)
(rcPaint RECT)
(fRestore BOOL)
(fIncUpdate BOOL)
(rgbReserved (array 32 BYTE))))
(defvarl CW_USEDEFAULT #x-80000000)
(defvarl WS_OVERLAPPEDWINDOW #x00cf0000)
(defvarl SW_SHOWDEFAULT 5)
(defvarl WM_DESTROY 2)
(defvarl WM_PAINT 15)
(defvarl COLOR_WINDOW 5)
(deffi-cb wndproc-fn LRESULT (HWND UINT LPARAM WPARAM))
(with-dyn-lib "kernel32.dll"
(deffi GetModuleHandle "GetModuleHandleW" HINSTANCE (wstr)))
(with-dyn-lib "user32.dll"
(deffi RegisterClass "RegisterClassW" ATOM ((ptr-in WNDCLASS)))
(deffi CreateWindowEx "CreateWindowExW" HWND (DWORD
LPCTSTR LPCTSTR
DWORD
int int int int
HWND HMENU HINSTANCE
LPVOID))
(deffi ShowWindow "ShowWindow" BOOL (HWND int))
(deffi GetMessage "GetMessageW" BOOL ((ptr-out MSG) HWND UINT UINT))
(deffi TranslateMessage "TranslateMessage" BOOL ((ptr-in MSG)))
(deffi DispatchMessage "DispatchMessageW" LRESULT ((ptr-in MSG)))
(deffi PostQuitMessage "PostQuitMessage" void (int))
(deffi DefWindowProc "DefWindowProcW" LRESULT (HWND UINT LPARAM WPARAM))
(deffi BeginPaint "BeginPaint" HDC (HWND (ptr-out PAINTSTRUCT)))
(deffi EndPaint "EndPaint" BOOL (HWND (ptr-in PAINTSTRUCT)))
(deffi FillRect "FillRect" int (HDC (ptr-in RECT) HBRUSH)))
(defun WindowProc (hwnd uMsg wParam lParam)
(caseql* uMsg
(WM_DESTROY
(PostQuitMessage 0)
0)
(WM_PAINT
(let* ((ps (new PAINTSTRUCT))
(hdc (BeginPaint hwnd ps)))
(FillRect hdc ps.rcPaint (cptr-int (succ COLOR_WINDOW) 'HBRUSH))
(EndPaint hwnd ps)
0))
(t (DefWindowProc hwnd uMsg wParam lParam))))
(let* ((hInstance (GetModuleHandle nil))
(wc (new WNDCLASS
lpfnWndProc [wndproc-fn WindowProc]
hInstance hInstance
lpszClassName "Sample Window Class")))
(RegisterClass wc)
(let ((hwnd (CreateWindowEx 0 wc.lpszClassName "Learn to Program Windows"
WS_OVERLAPPEDWINDOW
CW_USEDEFAULT CW_USEDEFAULT
CW_USEDEFAULT CW_USEDEFAULT
NULL NULL hInstance NULL)))
(unless (equal hwnd NULL)
(ShowWindow hwnd SW_SHOWDEFAULT)
(let ((msg (new MSG)))
(while (GetMessage msg NULL 0 0)
(TranslateMessage msg)
(DispatchMessage msg))))))