diff options
Diffstat (limited to 'demostuff')
| -rw-r--r-- | demostuff | 177 |
1 files changed, 0 insertions, 177 deletions
diff --git a/demostuff b/demostuff deleted file mode 100644 index c3e3f0c..0000000 --- a/demostuff +++ /dev/null @@ -1,177 +0,0 @@ -#| -This file of "demostuff", used by the demo scripts, loads Gtk -and defines gapp, window, box, button, text, xtext, and xlabel. - gapp Establishes a Gtk app. Its arguments are the app name - and the code to be executed in the app. - window Establishes a window. Its arguments are the name of - the window object, the name of the app the window is - used in, the window title, and the default width and - height of the window. - box Establishes a box to place Gtk objects in. Its three - arguments are, first, h or v, for whether the contents - of the box are to be organized horizontally or - vertically, second, what box to establish, and third, - what object the box is to be placed in. - button Establishes a button. Its arguments are, what button - to establish, the initial label text on the button, - the object the button is to be placed in, and the code - to be executed when the button is pressed. - mbutton Is like button, except the button label text will be - left-aligned instead of centered. It's for use in a - column of buttons, such as a menu, where it might look - neater to not center the button labels. - text Establishes a text display object, which Gtk calls a - label. Its arguments are the name of the text object, - the initial text, and what object to place the text - object in. - xtext Is a function to display some text in a text object. - Its arguments are what text object to display the text - in, and what text to display. - xlabel Is a function to update a button label. Its arguments - are the button and the new text. -|# - -(load-shared-object "libgtk-3.so.0") - -; Gtk relies on being able to divide by zero. To prevent it from -; being an error, the following line changes the floating point -; errors to just overflow and invalid, and not division-by-zero. -; This isn't needed in most programming languages, because most -; of them default to having it not be an error. -(sb-int:set-floating-point-modes :traps '(:overflow :invalid)) - - -; Gtk function prototypes: each has a code, such as xx or vxs. The -; first letter of the code is the return value type, and the rest are -; the argument types: -; v = void -; x = void* -; i = int -; l = long -; f = float -; d = double -; s = c-string -; y = vxx function -(loop as (gfunc xx) in - '((gtk_application_window_new xx) - (gtk_window_set_title vxs) - (gtk_window_set_default_size vxii) - (gtk_button_box_new xi) - (gtk_size_group_new xi) - (gtk_bin_get_child xx) - (gtk_label_set_xalign vxf) - (gtk_container_add vxx) - (gtk_label_new xs) - (gtk_label_set_text vxs) - (gtk_button_set_label vxs) - (gtk_button_get_label sx) - (gtk_button_new_with_label xs) - (gtk_widget_destroy xx) - (gtk_application_new xsi) - (g_application_run ixix) - (g_object_unref vx) - (gtk_widget_show_all vx) - (g_signal_connect_data lxsyxxi)) - as types = (loop as x across (string xx) - collect (ecase (char-downcase x) - (#\v 'void) - (#\x '(* t)) - (#\i 'int) - (#\l 'long) - (#\f 'float) - (#\d 'double) - (#\s 'c-string) - (#\y '(function void (* t) (* t))))) - as rv = (car types) - as args = (loop as argname in '(a b c d e f g h i j k l m) - as argtype in (cdr types) - collect (list argname argtype)) - do (eval `(define-alien-routine ,gfunc ,rv ,@args))) - - -; callbackname makes a callback name from an object name. -; The eval-when makes it usable during macro expansions. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun callbackname (object) - (intern (concatenate 'string (symbol-name object) "-CALLBACK")))) - -; 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) - (eval `(defparameter ,awin nil)) - `(progn - (setf ,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) - (eval `(defparameter ,abox nil)) - (let ((horizvert (case hv (h 0) (v 1) (t (error - "The first argument to box should be h or v, not ~a" hv))))) - `(progn - (setf ,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 body) - (eval `(defparameter ,abutton nil)) - (let ((cb (callbackname abutton))) - (eval `(sb-alien::define-alien-callback - ,cb void ((a (* t)) (b (* t))) - (declare (ignore a b)) - ,@body)) - `(progn - (setf ,abutton (gtk_button_new_with_label ,buttonlabel)) - (g_signal_connect_data ,abutton "clicked" ,cb nil nil 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 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) - (eval `(defparameter ,atext nil)) - `(progn - (setf ,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 body) - (eval `(defparameter ,theapp nil)) - (let ((cb (callbackname theapp))) - (eval `(sb-alien::define-alien-callback - ,cb void ((a (* t)) (b (* t))) - (declare (ignore a b)) - ,@body)) - `(progn - (setf ,theapp (gtk_application_new nil 0)) - (g_signal_connect_data ,theapp "activate" ,cb nil nil 0)))) - -; End of the demostuff file, which gets loaded by each demo script. |