diff options
| -rwxr-xr-x | demo2 | 10 | ||||
| -rwxr-xr-x | demo3 | 2 | ||||
| -rw-r--r-- | demostuff.tl | 124 | ||||
| -rwxr-xr-x | makesans.tl | 13 | ||||
| -rwxr-xr-x | menu | 2 |
5 files changed, 144 insertions, 7 deletions
@@ -17,13 +17,13 @@ (defparameter numar 'a) ; 'r = I II II IV V. 'a = 1 2 3 4 5. ; Button number (bn) and button number text (bnt): -(defun bn (n) (nth (1- n) '(11 22 33 44 55))) +(defun bn (n) (nth (pred n) '(11 22 33 44 55))) (defun bnt (n) (format nil (if (eq numar 'a) "~d" "~@R") (bn n))) (defun togglenumar () - (setq numar (if (eq numar 'a) 'r 'a)) - (loop as button in (list b21 b22 b23 b24 b25) - as n from 1 to 5 - do (xlabel button (bnt n)))) + (set numar (if (eq numar 'a) 'r 'a)) + (each ((button (list b21 b22 b23 b24 b25)) + (n (range 1 5))) + (xlabel button (bnt n)))) (defun xnum (n) (xtext num2 (format nil "~R" n))) @@ -13,6 +13,6 @@ (defun relabel (button number) (let* ((old (gtk_button_get_label button)) - (isdigits (<= 0 (- (char-int (aref old 0)) (char-int #\0)) 9)) + (isdigits (<= 0 (- (chr-int [old 0]) (chr-int #\0)) 9)) (new (format nil (if isdigits "~@R" "~d") number))) (xlabel button new))) diff --git a/demostuff.tl b/demostuff.tl new file mode 100644 index 0000000..4ec23ab --- /dev/null +++ b/demostuff.tl @@ -0,0 +1,124 @@ +(defun letter-to-type (ch) + (caseql ch + (#\v 'void) + (#\x 'cptr) + (#\i 'int) + (#\l 'long) + (#\f 'float) + (#\d 'double) + (#\s 'str) + (#\y 'closure))) + +(defmacro df (name sig) + (let ((si (list-str (symbol-name sig)))) + ^(deffi ,name ,(symbol-name name) ,(letter-to-type (car si)) + ,[mapcar letter-to-type (cdr si)]))) + +(with-dyn-lib "libgtk-3.so.0" + (df gtk_application_window_new xx) + (df gtk_window_set_title vxs) + (df gtk_window_set_default_size vxii) + (df gtk_button_box_new xi) + (df gtk_size_group_new xi) + (df gtk_bin_get_child xx) + #;(df gtk_label_set_xalign vxf) + (df gtk_container_add vxx) + (df gtk_label_new xs) + (df gtk_label_set_text vxs) + (df gtk_button_set_label vxs) + (df gtk_button_get_label sx) + (df gtk_button_new_with_label xs) + (df gtk_widget_destroy xx) + (df gtk_application_new xsi) + (df g_application_run ixix) + (df g_object_unref vx) + (df gtk_widget_show_all vx) + (df g_signal_connect_data lxsyxxi)) + +(deffi-cb button-cb void (cptr cptr)) + +(deffi-cb app-cb void (cptr cptr)) + +(defsymacro null cptr-null) + +(defun callbackname (object) + (make-sym `@object-cb`)) + +; window establishes a Gtk window object. +; The arguments are, what window object to establish, what +; application the window is used in, the window title, and +; the width and height of the window. +(defmacro window (awin app title wid ht) + ^(progn + (defparm ,awin (gtk_application_window_new ,app)) + (gtk_window_set_title ,awin ,title) + (gtk_window_set_default_size ,awin ,wid ,ht))) + +; box establishes a box object. The arguments are, whether the box +; contents are organized horizontally or vertically (h or v), what +; box is to be established, and what object to place the box in. +(defmacro box (hv abox placement) + (let ((horizvert (caseql hv + (h 0) (v 1) + (t (error "The first argument to box should \ + \ be h or v, not ~a" hv))))) + ^(progn + (defparm ,abox nil) + (progn + (set ,abox (gtk_button_box_new ,horizvert)) + (gtk_container_add ,placement ,abox))))) + +; button establishes a Gtk button object. The arguments are, +; the name of the button object, the text shown on the button, +; what object to place the button in, and the action of the +; button, which can be any sequence of code. +(defmacro button (abutton buttonlabel placement . body) + (let ((cb (callbackname abutton))) + ^(progn + (defparm ,abutton nil) + (defun ,cb (a b) + ,*body) + (set ,abutton (gtk_button_new_with_label ,buttonlabel)) + (g_signal_connect_data ,abutton "clicked" [button-cb ,cb] + null null 0) + (gtk_container_add ,placement ,abutton)))) + +; mbutton is like button, except that the button label text will be +; left aligned instead of centered, to make it neater in a column of +; buttons, such as for a menu. +(defmacro mbutton (abutton buttonlabel placement . body) + ^(progn + (button ,abutton ,buttonlabel ,placement ,*body) + (let ((thelabel (gtk_bin_get_child ,abutton))) + #;(gtk_label_set_xalign thelabel 0.0)))) + +; text establishes a Gtk "label" object which is actually a text +; display object. The arguments are, what text object to +; establish, the initial text to display, and what object to +; place this text object in. +(defmacro text (atext text0 placement) + ^(progn + (defparm ,atext (gtk_label_new ,text0)) + (gtk_container_add ,placement ,atext))) + +; xtext changes the text in a text object. +(defun xtext (textobject newtext) + (gtk_label_set_text textobject newtext)) + +; xlabel changes the text label on a button. +(defun xlabel (button newtext) + (gtk_button_set_label button newtext)) + +; gapp establishes a Gtk application. The arguments are, +; the name of the application object, and the code to be +; executed by the application. +(defmacro gapp (theapp . body) + (let ((cb (callbackname theapp))) + ^(progn + (defparm ,theapp nil) + (defun ,cb (a b) + ,*body) + (set ,theapp (gtk_application_new nil 0)) + (g_signal_connect_data ,theapp "activate" [app-cb ,cb] null null 0)))) + +(defmacro defparameter (name val) ^(defparm ,name ,val)) diff --git a/makesans.tl b/makesans.tl new file mode 100755 index 0000000..bef6fc3 --- /dev/null +++ b/makesans.tl @@ -0,0 +1,13 @@ +#!/usr/bin/env txr + +; This script, makesans, uses sbcl to make sanssbcl, which can then +; be copied to a Linux PC that doesn't have sbcl. + +(defun load-and-go () + (load "demostuff.tl") + (load "menu") + (each ((i (range 1 9))) + (load `demo@i`)) + (menu)) + +(load-and-go) @@ -15,5 +15,5 @@ (mbutton dodemo8 "de minimis" mainbox (demo8)) (mbutton dodemo9 "de minimis" mainbox (demo9)) (gtk_widget_show_all win)) - (g_application_run demos 0 nil) + (g_application_run demos 0 null) (g_object_unref demos)) |