From 94ee69847a8e233b998ddd8c743087a063d27a44 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 6 Feb 2019 16:50:30 -0800 Subject: More TXR porting: add suffixes to files; remove SBCL materials. --- demo1 | 16 ------ demo1.tl | 16 ++++++ demo2 | 29 ---------- demo2.tl | 29 ++++++++++ demo3 | 18 ------- demo3.tl | 18 +++++++ demo4 | 7 --- demo4.tl | 7 +++ demo5 | 7 --- demo5.tl | 7 +++ demo6 | 7 --- demo6.tl | 7 +++ demo7 | 7 --- demo7.tl | 7 +++ demo8 | 7 --- demo8.tl | 7 +++ demo9 | 7 --- demo9.tl | 7 +++ demos | 16 ------ demostuff | 177 ------------------------------------------------------------ makesans | 12 ----- makesans.tl | 2 +- menu | 19 ------- menu.tl | 19 +++++++ sanssbcl | Bin 39493272 -> 0 bytes 25 files changed, 125 insertions(+), 330 deletions(-) delete mode 100755 demo1 create mode 100755 demo1.tl delete mode 100755 demo2 create mode 100755 demo2.tl delete mode 100755 demo3 create mode 100755 demo3.tl delete mode 100755 demo4 create mode 100755 demo4.tl delete mode 100755 demo5 create mode 100755 demo5.tl delete mode 100755 demo6 create mode 100755 demo6.tl delete mode 100755 demo7 create mode 100755 demo7.tl delete mode 100755 demo8 create mode 100755 demo8.tl delete mode 100755 demo9 create mode 100755 demo9.tl delete mode 100755 demos delete mode 100644 demostuff delete mode 100755 makesans delete mode 100755 menu create mode 100755 menu.tl delete mode 100755 sanssbcl diff --git a/demo1 b/demo1 deleted file mode 100755 index 3a5647d..0000000 --- a/demo1 +++ /dev/null @@ -1,16 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo1 () - (window demo1 demos "Four Button Demo" 300 150) - (box h outerbox1 demo1) - (box v mainbox1 outerbox1) - (box h buttons1 mainbox1) - (box h numbox1 mainbox1) - (box v leftbuttons1 buttons1) - (box v rightbuttons1 buttons1) - (text num1 "Zero" numbox1) - (button b1nw "1" leftbuttons1 (xtext num1 "One")) - (button b1sw "2" leftbuttons1 (xtext num1 "Two")) - (button b1ne "3" rightbuttons1 (xtext num1 "Three")) - (button b1se "4" rightbuttons1 (xtext num1 "Four")) - (gtk_widget_show_all demo1)) diff --git a/demo1.tl b/demo1.tl new file mode 100755 index 0000000..3a5647d --- /dev/null +++ b/demo1.tl @@ -0,0 +1,16 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo1 () + (window demo1 demos "Four Button Demo" 300 150) + (box h outerbox1 demo1) + (box v mainbox1 outerbox1) + (box h buttons1 mainbox1) + (box h numbox1 mainbox1) + (box v leftbuttons1 buttons1) + (box v rightbuttons1 buttons1) + (text num1 "Zero" numbox1) + (button b1nw "1" leftbuttons1 (xtext num1 "One")) + (button b1sw "2" leftbuttons1 (xtext num1 "Two")) + (button b1ne "3" rightbuttons1 (xtext num1 "Three")) + (button b1se "4" rightbuttons1 (xtext num1 "Four")) + (gtk_widget_show_all demo1)) diff --git a/demo2 b/demo2 deleted file mode 100755 index cd757ce..0000000 --- a/demo2 +++ /dev/null @@ -1,29 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo2 () - (window demo2 demos "Numerals Demo" 250 250) - (box h outerbox2 demo2) - (box v mainbox2 outerbox2) - (box h numbox2 mainbox2) - (button b21 (bnt 1) mainbox2 (xnum (bn 1))) - (button b22 (bnt 2) mainbox2 (xnum (bn 2))) - (button b23 (bnt 3) mainbox2 (xnum (bn 3))) - (button b24 (bnt 4) mainbox2 (xnum (bn 4))) - (button b25 (bnt 5) mainbox2 (xnum (bn 5))) - (button numeralbutton2 "Numerals" mainbox2 (togglenumar)) - (text num2 "zero" numbox2) - (gtk_widget_show_all demo2)) - -(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 (pred n) '(11 22 33 44 55))) -(defun bnt (n) (format nil (if (eq numar 'a) "~d" "~@R") (bn n))) - -(defun togglenumar () - (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))) diff --git a/demo2.tl b/demo2.tl new file mode 100755 index 0000000..cd757ce --- /dev/null +++ b/demo2.tl @@ -0,0 +1,29 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo2 () + (window demo2 demos "Numerals Demo" 250 250) + (box h outerbox2 demo2) + (box v mainbox2 outerbox2) + (box h numbox2 mainbox2) + (button b21 (bnt 1) mainbox2 (xnum (bn 1))) + (button b22 (bnt 2) mainbox2 (xnum (bn 2))) + (button b23 (bnt 3) mainbox2 (xnum (bn 3))) + (button b24 (bnt 4) mainbox2 (xnum (bn 4))) + (button b25 (bnt 5) mainbox2 (xnum (bn 5))) + (button numeralbutton2 "Numerals" mainbox2 (togglenumar)) + (text num2 "zero" numbox2) + (gtk_widget_show_all demo2)) + +(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 (pred n) '(11 22 33 44 55))) +(defun bnt (n) (format nil (if (eq numar 'a) "~d" "~@R") (bn n))) + +(defun togglenumar () + (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))) diff --git a/demo3 b/demo3 deleted file mode 100755 index d2ec257..0000000 --- a/demo3 +++ /dev/null @@ -1,18 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo3 () - (window demo3 demos "Dates Demo" 300 200) - (box h outerbox3 demo3) - (box v mainbox3 outerbox3) - (button date1 "1066" mainbox3 (relabel date1 1066)) - (button date2 "1415" mainbox3 (relabel date2 1415)) - (button date3 "1492" mainbox3 (relabel date3 1492)) - (button date4 "1620" mainbox3 (relabel date4 1620)) - (button date5 "1776" mainbox3 (relabel date5 1776)) - (gtk_widget_show_all demo3)) - -(defun relabel (button number) - (let* ((old (gtk_button_get_label button)) - (isdigits (<= 0 (- (chr-int [old 0]) (chr-int #\0)) 9)) - (new (format nil (if isdigits "~@R" "~d") number))) - (xlabel button new))) diff --git a/demo3.tl b/demo3.tl new file mode 100755 index 0000000..d2ec257 --- /dev/null +++ b/demo3.tl @@ -0,0 +1,18 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo3 () + (window demo3 demos "Dates Demo" 300 200) + (box h outerbox3 demo3) + (box v mainbox3 outerbox3) + (button date1 "1066" mainbox3 (relabel date1 1066)) + (button date2 "1415" mainbox3 (relabel date2 1415)) + (button date3 "1492" mainbox3 (relabel date3 1492)) + (button date4 "1620" mainbox3 (relabel date4 1620)) + (button date5 "1776" mainbox3 (relabel date5 1776)) + (gtk_widget_show_all demo3)) + +(defun relabel (button number) + (let* ((old (gtk_button_get_label button)) + (isdigits (<= 0 (- (chr-int [old 0]) (chr-int #\0)) 9)) + (new (format nil (if isdigits "~@R" "~d") number))) + (xlabel button new))) diff --git a/demo4 b/demo4 deleted file mode 100755 index 918df4a..0000000 --- a/demo4 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo4 () - (window demo4 demos "de minimis" 300 150) - (box v deminimisbox4 demo4) - (text deminimismsg4 "This demo is not yet defined." deminimisbox4) - (gtk_widget_show_all demo4)) diff --git a/demo4.tl b/demo4.tl new file mode 100755 index 0000000..918df4a --- /dev/null +++ b/demo4.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo4 () + (window demo4 demos "de minimis" 300 150) + (box v deminimisbox4 demo4) + (text deminimismsg4 "This demo is not yet defined." deminimisbox4) + (gtk_widget_show_all demo4)) diff --git a/demo5 b/demo5 deleted file mode 100755 index bcf4cc2..0000000 --- a/demo5 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo5 () - (window demo5 demos "de minimis" 300 150) - (box v deminimisbox5 demo5) - (text deminimismsg5 "This demo is not yet defined." deminimisbox5) - (gtk_widget_show_all demo5)) diff --git a/demo5.tl b/demo5.tl new file mode 100755 index 0000000..bcf4cc2 --- /dev/null +++ b/demo5.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo5 () + (window demo5 demos "de minimis" 300 150) + (box v deminimisbox5 demo5) + (text deminimismsg5 "This demo is not yet defined." deminimisbox5) + (gtk_widget_show_all demo5)) diff --git a/demo6 b/demo6 deleted file mode 100755 index 75ba182..0000000 --- a/demo6 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo6 () - (window demo6 demos "de minimis" 300 150) - (box v deminimisbox6 demo6) - (text deminimismsg6 "This demo is not yet defined." deminimisbox6) - (gtk_widget_show_all demo6)) diff --git a/demo6.tl b/demo6.tl new file mode 100755 index 0000000..75ba182 --- /dev/null +++ b/demo6.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo6 () + (window demo6 demos "de minimis" 300 150) + (box v deminimisbox6 demo6) + (text deminimismsg6 "This demo is not yet defined." deminimisbox6) + (gtk_widget_show_all demo6)) diff --git a/demo7 b/demo7 deleted file mode 100755 index e816770..0000000 --- a/demo7 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo7 () - (window demo7 demos "de minimis" 300 150) - (box v deminimisbox7 demo7) - (text deminimismsg7 "This demo is not yet defined." deminimisbox7) - (gtk_widget_show_all demo7)) diff --git a/demo7.tl b/demo7.tl new file mode 100755 index 0000000..e816770 --- /dev/null +++ b/demo7.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo7 () + (window demo7 demos "de minimis" 300 150) + (box v deminimisbox7 demo7) + (text deminimismsg7 "This demo is not yet defined." deminimisbox7) + (gtk_widget_show_all demo7)) diff --git a/demo8 b/demo8 deleted file mode 100755 index 2893d2b..0000000 --- a/demo8 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo8 () - (window demo8 demos "de minimis" 300 150) - (box v deminimisbox8 demo8) - (text deminimismsg8 "This demo is not yet defined." deminimisbox8) - (gtk_widget_show_all demo8)) diff --git a/demo8.tl b/demo8.tl new file mode 100755 index 0000000..2893d2b --- /dev/null +++ b/demo8.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo8 () + (window demo8 demos "de minimis" 300 150) + (box v deminimisbox8 demo8) + (text deminimismsg8 "This demo is not yet defined." deminimisbox8) + (gtk_widget_show_all demo8)) diff --git a/demo9 b/demo9 deleted file mode 100755 index 228c176..0000000 --- a/demo9 +++ /dev/null @@ -1,7 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun demo9 () - (window demo9 demos "de minimis" 300 150) - (box v deminimisbox9 demo9) - (text deminimismsg9 "This demo is not yet defined." deminimisbox9) - (gtk_widget_show_all demo9)) diff --git a/demo9.tl b/demo9.tl new file mode 100755 index 0000000..228c176 --- /dev/null +++ b/demo9.tl @@ -0,0 +1,7 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun demo9 () + (window demo9 demos "de minimis" 300 150) + (box v deminimisbox9 demo9) + (text deminimismsg9 "This demo is not yet defined." deminimisbox9) + (gtk_widget_show_all demo9)) diff --git a/demos b/demos deleted file mode 100755 index 37008ba..0000000 --- a/demos +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash -./sanssbcl 2> >(sed '/^Backtrace/,$d;/^; /d;/^$/d') - -# This script, demos, uses sanssbcl to run the demos, with or without -# sbcl installed. -# -# sanssbcl has to be present with this script and the demo scripts. -# To make the demos executable do this: chmod +x demos -# To invoke the demos, do this: ./demos -# -# If you want to make sanssbcl, it can be made on a Linux PC that -# has sbcl installed by using the makesans script. To make -# sanssbcl there, do this: chmod +x makesans -# ./makesans -# Then you can copy sanssbcl to another Linux PC, whether it has -# sbcl installed or not. 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. diff --git a/makesans b/makesans deleted file mode 100755 index a33c8de..0000000 --- a/makesans +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/local/bin/sbcl --script - -; 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") - (load "menu") - (loop as n from 1 to 9 do (load (format nil "demo~d" n))) - (menu)) - -(save-lisp-and-die "sanssbcl" :executable t :toplevel #'load-and-go) diff --git a/makesans.tl b/makesans.tl index bef6fc3..f2b839b 100755 --- a/makesans.tl +++ b/makesans.tl @@ -4,7 +4,7 @@ ; be copied to a Linux PC that doesn't have sbcl. (defun load-and-go () - (load "demostuff.tl") + (load "demostuff") (load "menu") (each ((i (range 1 9))) (load `demo@i`)) diff --git a/menu b/menu deleted file mode 100755 index a0d3dff..0000000 --- a/menu +++ /dev/null @@ -1,19 +0,0 @@ -; Refer to the demostuff file for definitions and descriptions. - -(defun menu () - (gapp demos - (window win demos "Demos Menu" 300 350) - (box h outerbox win) - (box v mainbox outerbox) - (mbutton dodemo1 "Four Button Demo" mainbox (demo1)) - (mbutton dodemo2 "Numerals Demo" mainbox (demo2)) - (mbutton dodemo3 "Dates Demo" mainbox (demo3)) - (mbutton dodemo4 "de minimis" mainbox (demo4)) - (mbutton dodemo5 "de minimis" mainbox (demo5)) - (mbutton dodemo6 "de minimis" mainbox (demo6)) - (mbutton dodemo7 "de minimis" mainbox (demo7)) - (mbutton dodemo8 "de minimis" mainbox (demo8)) - (mbutton dodemo9 "de minimis" mainbox (demo9)) - (gtk_widget_show_all win)) - (g_application_run demos 0 null) - (g_object_unref demos)) diff --git a/menu.tl b/menu.tl new file mode 100755 index 0000000..a0d3dff --- /dev/null +++ b/menu.tl @@ -0,0 +1,19 @@ +; Refer to the demostuff file for definitions and descriptions. + +(defun menu () + (gapp demos + (window win demos "Demos Menu" 300 350) + (box h outerbox win) + (box v mainbox outerbox) + (mbutton dodemo1 "Four Button Demo" mainbox (demo1)) + (mbutton dodemo2 "Numerals Demo" mainbox (demo2)) + (mbutton dodemo3 "Dates Demo" mainbox (demo3)) + (mbutton dodemo4 "de minimis" mainbox (demo4)) + (mbutton dodemo5 "de minimis" mainbox (demo5)) + (mbutton dodemo6 "de minimis" mainbox (demo6)) + (mbutton dodemo7 "de minimis" mainbox (demo7)) + (mbutton dodemo8 "de minimis" mainbox (demo8)) + (mbutton dodemo9 "de minimis" mainbox (demo9)) + (gtk_widget_show_all win)) + (g_application_run demos 0 null) + (g_object_unref demos)) diff --git a/sanssbcl b/sanssbcl deleted file mode 100755 index 71a7f6d..0000000 Binary files a/sanssbcl and /dev/null differ -- cgit v1.2.3