September 2017 Update

Task/Window-creation/BaCon/window-creation.bacon

@@ -0,0 +1,7 @@
+REM empty window
+INCLUDE "hug.bac"
+
+mainwin = WINDOW("Rosetta Code empty", 400, 300)
+
+REM start gtk event loop...
+DISPLAY

Task/Window-creation/Gambas/window-creation.gambas

@@ -0,0 +1,3 @@
+Public Sub Form_Open()
+
+End

Task/Window-creation/Julia/window-creation.julia

@@ -0,0 +1,5 @@
+# v0.6
+
+using Tk
+
+w = Toplevel("Example")

Task/Window-creation/Nimrod/window-creation-1.nimrod

@@ -1,52 +0,0 @@
-import
-  gdk2, glib2, gtk2
-
-proc thisDestroy(widget: pWidget, data: pgpointer){.cdecl.} =
-  main_quit()
-
-const
-  Inside: cstring = "Mouse is over label"
-  OutSide: cstring = "Mouse is not over label"
-
-var
-  OverButton: bool
-
-nimrod_init()
-var window = window_new(gtk2.WINDOW_TOPLEVEL)
-var stackbox = vbox_new(TRUE, 10)
-var button1 = button_new("Move mouse over button")
-var buttonstyle = copy(get_style(Button1))
-ButtonStyle.bg[STATE_PRELIGHT].pixel = 0
-ButtonStyle.bg[STATE_PRELIGHT].red = -1'i16
-ButtonStyle.bg[STATE_PRELIGHT].blue = 0'i16
-ButtonStyle.bg[STATE_PRELIGHT].green = 0'i16
-set_style(button1, buttonstyle)
-var button2 = button_new()
-var ALabel = label_new(Outside)
-var button3 = button_new("Quit")
-
-
-proc ChangeLabel(P: PWidget, Event: gdk2.PEventCrossing,
-                 Data: var bool){.cdecl.} =
-  if Not Data: set_text(ALabel, Inside)
-  else: set_text(ALabel, Outside)
-  Data = Not Data
-
-
-add(button2, ALAbel)
-pack_start(stackbox, button1, TRUE, TRUE, 0)
-pack_start(stackbox, button2, TRUE, TRUE, 0)
-pack_start(stackbox, button3, TRUE, TRUE, 0)
-set_border_width(Window, 5)
-add(window, stackbox)
-discard signal_connect(window, "destroy",
-                   SIGNAL_FUNC(thisDestroy), nil)
-overbutton = False
-discard signal_connect(button1, "enter_notify_event",
-                   SIGNAL_FUNC(ChangeLabel), addr(OverButton))
-discard signal_connect(button1, "leave_notify_event",
-                   SIGNAL_FUNC(ChangeLabel), addr(OverButton))
-discard signal_connect(button3, "clicked",
-                   SIGNAL_FUNC(thisDestroy), nil)
-show_all(window)
-main()

Task/Window-creation/Nimrod/window-creation-2.nimrod

@@ -1,48 +0,0 @@
-import
-  sdl, sdl_image, colors
-
-var
-  screen, greeting: PSurface
-  r: TRect
-  event: TEvent
-  bgColor = colChocolate.int32
-
-if init(INIT_VIDEO) != 0:
-  quit "SDL failed to initialize!"
-
-screen = SetVideoMode(640, 480, 16, SWSURFACE or ANYFORMAT)
-if screen.isNil:
-  quit($sdl.getError())
-
-greeting = IMG_load("tux.png")
-if greeting.isNil:
-  echo "Failed to load tux.png"
-else:
-  ## convert the image to alpha and free the old one
-  var s = greeting.displayFormatAlpha()
-  swap(greeting, s)
-  s.freeSurface()
-
-r.x = 0
-r.y = 0
-
-block game_loop:
-  while true:
-
-    while pollEvent(addr event) > 0:
-      case event.kind
-      of QUITEV:
-        break game_loop
-      of KEYDOWN:
-        if EvKeyboard(addr event).keysym.sym == K_ESCAPE:
-          break game_loop
-      else:
-        discard
-
-    discard fillRect(screen, nil, bgColor)
-    discard blitSurface(greeting, nil, screen, addr r)
-    discard flip(screen)
-
-greeting.freeSurface()
-screen.freeSurface()
-sdl.Quit()

Task/Window-creation/Nimrod/window-creation-3.nimrod

@@ -1,73 +0,0 @@
-import xlib, xutil, x, keysym
-
-const
-  WINDOW_WIDTH = 400
-  WINDOW_HEIGHT = 300
-
-var
-  width, height: cuint
-  display: PDisplay
-  screen: cint
-  depth: int
-  win: TWindow
-  sizeHints: TXSizeHints
-
-proc create_window =
-  width = WINDOW_WIDTH
-  height = WINDOW_HEIGHT
-
-  display = XOpenDisplay(nil)
-  if display == nil:
-    echo("Verbindung zum X-Server fehlgeschlagen")
-    quit(1)
-
-  screen = XDefaultScreen(display)
-  depth = XDefaultDepth(display, screen)
-  var rootwin = XRootWindow(display, screen)
-  win = XCreateSimpleWindow(display, rootwin, 100, 10,
-                            width, height, 5,
-                            XBlackPixel(display, screen),
-                            XWhitePixel(display, screen))
-  size_hints.flags = PSize or PMinSize or PMaxSize
-  size_hints.min_width = width.cint
-  size_hints.max_width = width.cint
-  size_hints.min_height = height.cint
-  size_hints.max_height = height.cint
-  discard XSetStandardProperties(display, win, "Simple Window", "window",
-                         0, nil, 0, addr(size_hints))
-  discard XSelectInput(display, win, ButtonPressMask or KeyPressMask or
-                                     PointerMotionMask)
-  discard XMapWindow(display, win)
-
-proc close_window =
-  discard XDestroyWindow(display, win)
-  discard XCloseDisplay(display)
-
-var
-  xev: TXEvent
-
-proc process_event =
-  var key: TKeySym
-  case int(xev.theType)
-  of KeyPress:
-    key = XLookupKeysym(cast[ptr TXKeyEvent](addr(xev)), 0)
-    if key.int != 0:
-      echo("keyboard event",$key.int)
-    if key.int == 65307:    # <Esc>
-      quit(1)
-  of ButtonPressMask, PointerMotionMask:
-    Echo("Mouse event")
-  else: nil
-
-proc eventloop =
-  discard XFlush(display)
-  var num_events = int(XPending(display))
-  while num_events != 0:
-    dec(num_events)
-    discard XNextEvent(display, addr(xev))
-    process_event()
-
-create_window()
-while true:
-  eventloop()
-close_window()

Task/Window-creation/Nimrod/window-creation-4.nimrod

@@ -1,13 +0,0 @@
-import glut
-
-var win: int = 0
-
-proc myOnKeyPress(c: int8, v1, v2: cint) {.cdecl.} =
-   echo(c)
-   if c == 27:
-      glutDestroyWindow(win)
-
-glutInit()
-win = glutCreateWindow("Goodbye, World!")
-glutKeyboardFunc(TGlut1Char2IntCallback(myOnKeyPress))
-glutMainLoop()

Task/Window-creation/Nimrod/window-creation-5.nimrod

@@ -1,9 +0,0 @@
-# test a Windows GUI application
-
-import
-  windows, shellapi, nb30, mmsystem, shfolder
-
-#proc MessageBox(hWnd: int, lpText, lpCaption: CString, uType: uint): int
-# {stdcall, import: "MessageBox", header: "<windows.h>"}
-
-discard MessageBox(0, "Hello World!", "Nimrod GUI Application", 0)

Task/Window-creation/Phix/window-creation.phix

@@ -1,13 +1,16 @@
+--
+-- demo\rosetta\Window_creation.exw
+--
 include pGUI.e
 
 function esc_close(Ihandle /*ih*/, atom c)
     return iff(c=K_ESC?IUP_CLOSE:IUP_CONTINUE)
 end function
 
-    IupOpen("../pGUI/")
-    Ihandle dlg = IupDialog(IupVbox({IupLabel("hello")},"MARGIN=200x200"))
-    IupSetAttribute(dlg,"TITLE","Hello")
-    IupSetCallback(dlg, "K_ANY", Icallback("esc_close"))
-    IupShow(dlg)
-    IupMainLoop()
-    IupClose()
+IupOpen()
+Ihandle dlg = IupDialog(IupVbox({IupLabel("hello")},"MARGIN=200x200"))
+IupSetAttribute(dlg,"TITLE","Hello")
+IupSetCallback(dlg, "K_ANY", Icallback("esc_close"))
+IupShow(dlg)
+IupMainLoop()
+IupClose()

Task/Window-creation/TXR/window-creation-1.txr

@@ -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))

Task/Window-creation/TXR/window-creation-2.txr

@@ -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)))

Task/Window-creation/TXR/window-creation-3.txr

@@ -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))

Task/Window-creation/TXR/window-creation-4.txr

@@ -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))))))