From: <cli...@li...> - 2008-06-25 23:05:39
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src ChangeLog,1.6303,1.6304 (Sam Steingold) 2. clisp/modules/clx/mit-clx display.lisp,1.4,1.5 package.lisp,1.6,1.7 (Sam Steingold) 3. clisp/modules/clx/new-clx clx.f,2.118,2.119 clx.lisp,1.31,1.32 (Sam Steingold) 4. clisp/src ChangeLog,1.6304,1.6305 (Sam Steingold) 5. clisp/modules/clx/new-clx clx.lisp,1.32,1.33 test.tst,1.27,1.28 (Sam Steingold) 6. clisp/modules/clx/new-clx/demos bball.lisp, 1.4, 1.5 bwindow.lisp, 1.3, 1.4 clclock.lisp, 1.1, 1.2 greynetic.lisp, 1.3, 1.4 hanoi.lisp, 1.3, 1.4 koch.lisp, 1.4, 1.5 petal.lisp, 1.3, 1.4 plaid.lisp, 1.3, 1.4 qix.lisp, 1.6, 1.7 recurrence.lisp, 1.3, 1.4 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Wed, 25 Jun 2008 22:43:51 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6303,1.6304 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv19532/src Modified Files: ChangeLog Log Message: (with-open-display): new macro Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6303 retrieving revision 1.6304 diff -u -d -r1.6303 -r1.6304 --- ChangeLog 25 Jun 2008 14:32:27 -0000 1.6303 +++ ChangeLog 25 Jun 2008 22:43:47 -0000 1.6304 @@ -1,5 +1,10 @@ 2008-06-25 Sam Steingold <sd...@gn...> + * modules/clx/mit-clx/display.lisp (with-open-display): define + * modules/clx/mit-clx/package.lisp (with-open-display): export + +2008-06-25 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/clx.f (CHANGE-PROPERTY): check the return value of XChangeProperty() (DISPLAY-VENDOR-NAME): return just one value ------------------------------ Message: 2 Date: Wed, 25 Jun 2008 22:43:49 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/clx/mit-clx display.lisp,1.4,1.5 package.lisp,1.6,1.7 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/modules/clx/mit-clx In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv19532/modules/clx/mit-clx Modified Files: display.lisp package.lisp Log Message: (with-open-display): new macro Index: display.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/mit-clx/display.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- display.lisp 14 Feb 2007 16:39:14 -0000 1.4 +++ display.lisp 25 Jun 2008 22:43:47 -0000 1.5 @@ -341,6 +341,15 @@ (declare (ignore screen)) (open-display host :display display :protocol protocol))) +(defmacro with-open-display ((display &rest options) &body body) + "Open a DISPLAY, execute BODY, close the DISPLAY." + `(let ((,display ,(if options + `(open-display ,@options) + `(open-default-display)))) + (unwind-protect (progn ,@body) + (when ,display + (close-display ,display))))) + (defun open-display (host &key (display 0) protocol authorization-name authorization-data) ;; Implementation specific routine to setup the buffer for a specific host and display. ;; This must interface with the local network facilities, and will probably do special Index: package.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/mit-clx/package.lisp,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- package.lisp 5 Apr 2005 22:48:09 -0000 1.6 +++ package.lisp 25 Jun 2008 22:43:47 -0000 1.7 @@ -108,7 +108,8 @@ merge-resources min-char-ascent min-char-attributes min-char-descent min-char-left-bearing min-char-right-bearing min-char-width missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation guess-display open-default-display open-display open-font + motion-events name-error no-operation guess-display open-display open-font + open-default-display with-open-display pixarray pixel pixmap pixmap-display pixmap-equal pixmap-error pixmap-format pixmap-format-bits-per-pixel pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad ------------------------------ Message: 3 Date: Wed, 25 Jun 2008 22:48:44 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/clx/new-clx clx.f,2.118,2.119 clx.lisp,1.31,1.32 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv21417/modules/clx/new-clx Modified Files: clx.f clx.lisp Log Message: move WM-HINTS to C to better handle word size differences Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.118 retrieving revision 2.119 diff -u -d -r2.118 -r2.119 --- clx.f 25 Jun 2008 14:32:27 -0000 2.118 +++ clx.f 25 Jun 2008 22:48:42 -0000 2.119 @@ -667,6 +667,17 @@ skipSTACK(1); return NIL; } +static object lookup_display (Display *dpy) { + object display = find_display(dpy); + if (nullp(display)) { + int fd; + X_CALL(fd = XConnectionNumber(dpy)); + pushSTACK(L_to_I(fd)); + pushSTACK(TheSubr(subr_self)->name); + error(error_condition,"~S: display ~S not found"); + } + return display; +} static Bool ensure_living_display (gcv_object_t *objf) { /* ensures that the object pointed to by 'objf' is really a display. @@ -5393,6 +5404,24 @@ } } +static void change_property (Display* dpy, Window win, Atom property, + Atom type, int format, int mode, + void* data, int size) { + Status r; + X_CALL(r = XChangeProperty(dpy,win,property,type,format,mode,data,size)); + if (r != Success) { /* FIXME: also print data */ + pushSTACK(check_error_code_reverse(r)); + pushSTACK(L_to_I(size)); + pushSTACK(L_to_I(mode)); + pushSTACK(L_to_I(format)); + pushSTACK(L_to_I(type)); + pushSTACK(L_to_I(property)); + pushSTACK(L_to_I(win)); + pushSTACK(TheSubr(subr_self)->name); + error(error_condition,"~S(~S ~S ~S ~S ~S ~S): ~S"); + } +} + DEFCHECKER(check_propmode,default=PropModeReplace, REPLACE=PropModeReplace \ PREPEND=PropModePrepend :APPEND=PropModeAppend) /* XLIB:CHANGE-PROPERTY window property data type format @@ -5425,24 +5454,12 @@ } { - Status r; DYNAMIC_ARRAY (data, unsigned char, len ? len : 1); { struct seq_map sm; sm.transform = &STACK_0; sm.data = data; sm.format = format; map_sequence(STACK_6,coerce_into_map,(void*)&sm); } - X_CALL(r = XChangeProperty (dpy, win, property, type, format, mode, data, - (end-start))); + change_property(dpy,win,property,type,format,mode,data,end-start); FREE_DYNAMIC_ARRAY (data); - if (r != Success) { - pushSTACK(check_error_code_reverse(r)); - pushSTACK(STACK_(4+1)); /* format */ - pushSTACK(STACK_(5+2)); pushSTACK(L_to_I(type)); - pushSTACK(STACK_(6+4)); /* data */ - pushSTACK(STACK_(7+5)); pushSTACK(L_to_I(property)); - pushSTACK(STACK_(8+7)); /* window */ - pushSTACK(TheSubr(subr_self)->name); - error(error_condition,"~S(~S ~S=~S ~S ~S=~S ~S): ~S"); - } } VALUES1(NIL); @@ -7731,10 +7748,8 @@ begin_callback (); - /* find the display. */ - pushSTACK(find_display (display)); - if (nullp (STACK_0)) - NOTREACHED; /* hmm? */ + /* find the display and push it on the STACK. */ + pushSTACK(lookup_display(display)); /* find the error handler */ pushSTACK(TheStructure (STACK_0)->recdata[slot_DISPLAY_ERROR_HANDLER]); @@ -7802,7 +7817,7 @@ int xlib_after_function (Display *display) { begin_callback (); - pushSTACK(find_display (display)); + pushSTACK(lookup_display(display)); funcall(TheStructure(STACK_0)->recdata[slot_DISPLAY_AFTER_FUNCTION],1); end_callback (); return 0; @@ -8057,6 +8072,144 @@ VALUES0; } +/* WM-HINTS & SET-WM-HINTS have to be in C because sizeof(XWMHints) + is arch-dependent (36 on i386 and 56 on amd64), see bug + https://sourceforge.net/tracker/?func=detail&atid=101355&aid=2002470&group_id=1355 */ +DEFCHECKER(check_wmh_initial_state,default=,WITHDRAWN=WithdrawnState \ + NORMAL=NormalState ICONIC=IconicState \ + /* Obsolete states no longer defined by ICCCM */ \ + ZOOM=ZoomState INACTIVE=InactiveState) +DEFCHECKER(check_wmh_flag,bitmasks=true, INPUT=InputHint STATE=StateHint \ + ICON-PIXMAP=IconPixmapHint ICON-WINDOW=IconWindowHint \ + ICON-POSITION=IconPositionHint ICON-MASK=IconMaskHint \ + WINDOW-GROUP=WindowGroupHint URGENCY=XUrgencyHint) +#include <X11/Xatom.h> /* for XA_WM_HINTS */ +DEFUN(XLIB:WM-HINTS, window) { + Display *dpy; + Window win = get_window_and_display(popSTACK(),&dpy); + Status r; + XWMHints *hints; + Atom actual_type; + int actual_format; + unsigned long leftover; + unsigned long nitems; + + X_CALL(r = XGetWindowProperty(dpy, win, XA_WM_HINTS, 0L, + (long)(sizeof(XWMHints)/4), false, + XA_WM_HINTS, &actual_type, &actual_format, + &nitems, &leftover, (unsigned char **)&hints)); + printf("\nr=%d type=%d format=%d nitems=%d leftover=%d hints=%x\n", + r,actual_type,actual_format,nitems,leftover,hints); + if (r == Success && actual_type == XA_WM_HINTS && actual_format == 32 + && nitems != 0 && hints != NULL) { + int count = 2; + long flags = hints->flags; + gcv_object_t *display; + pushSTACK(NIL); display = &STACK_0; + pushSTACK(`:FLAGS`); pushSTACK(check_wmh_flag_to_list(flags)); + if (flags & InputHint) { + pushSTACK(`:INPUT`); count += 2; + pushSTACK(hints->input ? `:ON` : `:OFF`); + } + if (flags & StateHint) { + pushSTACK(`:INITIAL-STATE`); count += 2; + pushSTACK(check_wmh_initial_state_reverse(hints->initial_state)); + } + if (flags & IconPixmapHint) { + if (nullp(*display)) *display = lookup_display(dpy); + pushSTACK(`:ICON-PIXMAP`); count += 2; + pushSTACK(make_pixmap(*display,hints->icon_pixmap)); + } + if (flags & IconWindowHint) { + if (nullp(*display)) *display = lookup_display(dpy); + pushSTACK(`:ICON-WINDOW`); count += 2; + pushSTACK(make_window(*display,hints->icon_window)); + } + if (flags & IconPositionHint) { + count += 4; + pushSTACK(`:ICON-X`); pushSTACK(L_to_I(hints->icon_x)); + pushSTACK(`:ICON-Y`); pushSTACK(L_to_I(hints->icon_y)); + } + if (flags & IconMaskHint) { + if (nullp(*display)) *display = lookup_display(dpy); + pushSTACK(`:ICON-MASK`); count += 2; + pushSTACK(make_pixmap(*display,hints->icon_mask)); + } + if (flags & WindowGroupHint) { + pushSTACK(`:WINDOW-GROUP`); count += 2; + pushSTACK(L_to_I(hints->window_group)); /* FIXME: raw XID?! */ + } + funcall(`XLIB::MAKE-WM-HINTS`,count); + XFree((char*)hints); + skipSTACK(1); /* drop display */ + } else { + if (hints != NULL) XFree((char*)hints); + VALUES0; + } +} +enum { + slot_WM_HINTS_INPUT = 1, + slot_WM_INITIAL_STATE, + slot_WM_ICON_PIXMAP, + slot_WM_ICON_WINDOW, + slot_WM_ICON_X, + slot_WM_ICON_Y, + slot_WM_ICON_MASK, + slot_WM_WINDOW_GROUP, + slot_WM_FLAGS, + wm_hints_structure_size +}; +DEFUN(XLIB:SET-WM-HINTS, window hints) { + Display *dpy; + Window win = get_window_and_display(STACK_1,&dpy); + XWMHints hints; + X_CALL(memset((void*)&hints,0,sizeof(hints))); + if (!typep_classname(STACK_0,`XLIB::WM-HINTS`)) + my_type_error(`XLIB::WM-HINTS`,STACK_0); +# define SLOT TheStructure(STACK_0)->recdata + if (!nullp(SLOT[slot_WM_FLAGS])) + hints.flags = check_wmh_flag_from_list(SLOT[slot_WM_FLAGS]); + if (!nullp(SLOT[slot_WM_HINTS_INPUT])) { + hints.input = eq(`:ON`,SLOT[slot_WM_HINTS_INPUT]); + hints.flags |= InputHint; + } + if (!nullp(SLOT[slot_WM_INITIAL_STATE])) { + hints.initial_state = check_wmh_initial_state(SLOT[slot_WM_INITIAL_STATE]); + hints.flags |= StateHint; + } + if (!nullp(SLOT[slot_WM_ICON_PIXMAP])) { + hints.icon_pixmap = get_pixmap(SLOT[slot_WM_ICON_PIXMAP]); + hints.flags |= IconPixmapHint; + } + if (!nullp(SLOT[slot_WM_ICON_WINDOW])) { + hints.icon_window = get_window(SLOT[slot_WM_ICON_WINDOW]); + hints.flags |= IconWindowHint; + } + if (!nullp(SLOT[slot_WM_ICON_X])) { + SLOT[slot_WM_ICON_X] = check_sint(SLOT[slot_WM_ICON_X]); + hints.icon_x = I_to_sint(SLOT[slot_WM_ICON_X]); + hints.flags |= IconPositionHint; + } + if (!nullp(SLOT[slot_WM_ICON_Y])) { + SLOT[slot_WM_ICON_Y] = check_sint(SLOT[slot_WM_ICON_Y]); + hints.icon_y = I_to_sint(SLOT[slot_WM_ICON_Y]); + hints.flags |= IconPositionHint; + } + if (!nullp(SLOT[slot_WM_ICON_MASK])) { + hints.icon_mask = get_pixmap(SLOT[slot_WM_ICON_MASK]); + hints.flags |= IconMaskHint; + } + if (!nullp(SLOT[slot_WM_WINDOW_GROUP])) { /* FIXME: raw XID?! */ + SLOT[slot_WM_WINDOW_GROUP] = check_slong(SLOT[slot_WM_WINDOW_GROUP]); + hints.window_group = I_to_slong(SLOT[slot_WM_WINDOW_GROUP]); + hints.flags |= WindowGroupHint; + } +# undef SLOT + change_property(dpy,win,XA_WM_HINTS,XA_WM_HINTS,32,PropModeReplace, + &hints,sizeof(hints)/4); + VALUES1(STACK_0); skipSTACK(2); /* return hints */ +} + ##if 0 /* ??? */ DEFUN(XLIB:DESCRIBE-ERROR, arg1 arg2) {UNDEFINED;} @@ -8107,7 +8260,6 @@ DEFUN(XLIB:WM-CLIENT-MACHINE, arg) {UNDEFINED;} DEFUN(XLIB:WM-COLORMAP-WINDOWS, arg) {UNDEFINED;} DEFUN(XLIB:WM-COMMAND, arg) {UNDEFINED;} -DEFUN(XLIB:WM-HINTS, arg) {UNDEFINED;} DEFUN(XLIB:WM-HINTS-FLAGS, arg) {UNDEFINED;} DEFUN(XLIB:WM-HINTS-ICON-MASK, arg) {UNDEFINED;} DEFUN(XLIB:WM-HINTS-ICON-PIXMAP, arg) {UNDEFINED;} Index: clx.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- clx.lisp 24 Jun 2008 19:46:12 -0000 1.31 +++ clx.lisp 25 Jun 2008 22:48:42 -0000 1.32 @@ -343,7 +343,7 @@ (:constructor nil) (:copier nil) (:conc-name %display-)) - foreign-pointer ;; these two slots are for use in clx.d only. + foreign-pointer ;; these two slots are for use in clx.f only. hash-table ;; .. so keep hands off here! plist after-function @@ -657,7 +657,8 @@ ;; Some of the functions below need decode-type and encode-type, ;; I provide here a limited implementation to get these functions working. -;; +;; sds: I am pretty sure that these should be eliminated and the code using +;; them should be moved to C for the same reasong (set-)wm-hints had to (defmacro decode-type (type value) (cond ((eq type 'pixmap) `(lookup-pixmap %buffer ,value)) ((eq type 'window) `(lookup-window %buffer ,value)) @@ -677,6 +678,7 @@ (t (error "Unknown type ~S." type)) )) (defstruct wm-hints + ;; keep in sync with clx.f (input nil ) (initial-state nil ) (icon-pixmap nil ) @@ -689,89 +691,7 @@ ;; may be extended in the future ) -(defun wm-hints (window) - (let ((prop (get-property window :WM_HINTS :type :WM_HINTS - :result-type 'vector))) - (when prop - (decode-wm-hints prop (window-display window))))) - (defsetf wm-hints set-wm-hints) -(defun set-wm-hints (window wm-hints) - (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) - wm-hints) - -(defun decode-wm-hints (vector display) - (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) - (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) - (setf (wm-hints-flags hints) flags) - (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) - (aref vector 1)))) - (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) - (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) - (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) - (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) - (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) - (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) - hints))) - -(defun encode-wm-hints (wm-hints) - (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) - (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 9) vector) - (type card16 flags)) - (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) - (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) - (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) - (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) - (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) - (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) - (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) - (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) - vector))) - ;;----------------------------------------------------------------------------- ;; WM_SIZE_HINTS ------------------------------ Message: 4 Date: Wed, 25 Jun 2008 22:48:46 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6304,1.6305 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv21417/src Modified Files: ChangeLog Log Message: move WM-HINTS to C to better handle word size differences Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6304 retrieving revision 1.6305 diff -u -d -r1.6304 -r1.6305 --- ChangeLog 25 Jun 2008 22:43:47 -0000 1.6304 +++ ChangeLog 25 Jun 2008 22:48:42 -0000 1.6305 @@ -1,5 +1,16 @@ 2008-06-25 Sam Steingold <sd...@gn...> + move WM-HINTS to C to better handle word size differences + * modules/clx/new-clx/clx.f (lookup_display, change_property): add + (CHANGE-PROPERTY): use change_property() + (xlib_error_handler, xlib_io_error_handler): use lookup_display() + (check_wmh_initial_state, check_wmh_flag): add DEFCHECKERs + (WM-HINTS, SET-WM-HINTS): implement + * modules/clx/new-clx/clx.lisp (wm-hints, set-wm-hints) + (decode-wm-hints, encode-wm-hints): remove + +2008-06-25 Sam Steingold <sd...@gn...> + * modules/clx/mit-clx/display.lisp (with-open-display): define * modules/clx/mit-clx/package.lisp (with-open-display): export ------------------------------ Message: 5 Date: Wed, 25 Jun 2008 23:05:30 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/clx/new-clx clx.lisp,1.32,1.33 test.tst,1.27,1.28 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv27700/modules/clx/new-clx Modified Files: clx.lisp test.tst Log Message: (with-open-display): define & export Index: clx.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.lisp,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- clx.lisp 25 Jun 2008 22:48:42 -0000 1.32 +++ clx.lisp 25 Jun 2008 23:05:28 -0000 1.33 @@ -170,7 +170,7 @@ display-trace ; for backwards compatibility describe-request describe-event describe-reply closed-display-p ;; extensions - open-default-display + open-default-display with-open-display display-get-default display-resource-manager-string screen-resource-string ;;; Only when using libXt: ;; last-event-processed last-timestamp-processed @@ -1314,6 +1314,15 @@ (setf (display-default-screen dpy) screen) dpy))) +(defmacro with-open-display ((display &rest options) &body body) + "Open a DISPLAY, execute BODY, close the DISPLAY." + `(let ((,display ,(if options + `(open-display ,@options) + `(open-default-display)))) + (unwind-protect (progn ,@body) + (when ,display + (close-display ,display))))) + ;;;; -------------------------------------------------------------------------- ;;;; Stuff, which is realy some internals of CLX, Index: test.tst =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/test.tst,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- test.tst 4 Jun 2008 18:02:42 -0000 1.27 +++ test.tst 25 Jun 2008 23:05:28 -0000 1.28 @@ -272,6 +272,86 @@ (xlib:display-finish-output *dpy*) NIL (xlib:display-p (show (xlib:close-display *dpy*))) T +(xlib:with-open-display (dpy) + (ext:appease-cerrors + (let ((count 0)) + (dolist (screen (xlib:display-roots dpy)) + (dolist (window (xlib:query-tree (xlib:screen-root screen))) + (let ((wmh (xlib:wm-hints window))) + (when wmh + (print (list (incf count) screen window wmh)) + ;; (setf (xlib:wm-hints window) wmh) + )))) + (integerp (print count))))) +T + +(xlib:with-open-display (dpy) + (let* ((win (xlib:create-window + :parent (xlib:screen-root (first (xlib:display-roots dpy))) + :x 0 :y 0 :width 50 :height 50)) + (pm (xlib:create-pixmap :width (random 100) :height (random 100) + :depth 8 :drawable win))) + (setf (xlib:wm-hints win) + (xlib:make-wm-hints)) + (xlib:display-finish-output dpy) + (xlib:wm-hints-icon-pixmap (xlib:wm-hints win)))) +T + +;; <http://article.gmane.org/gmane.lisp.clisp.devel/18431> +;; From: "Shawn Betts" <sa...@vc...> +(labels ((parent (dpy) (xlib:screen-root (first (xlib:display-roots dpy)))) + (make-win (dpy) + (xlib:create-window :parent (parent dpy) + :x 0 :y 0 :width 50 :height 50)) + (make-pixmap (window) + (xlib:create-pixmap :width (random 100) :height (random 100) + :depth 8 :drawable window)) + (window-list (dpy) (xlib:query-tree (parent dpy))) + (first-pass (dpy) + ;; Open a fresh connection. Create a window and a pixmap. + (let* ((dpy2 (xlib:open-default-display)) + (window (make-win dpy2)) (wid (xlib:window-id window)) + (pixmap (make-pixmap window))) + ;; make the pixmap the window's icon pixmap hint. + (setf (xlib:wm-hints window) + (xlib:make-wm-hints :icon-pixmap pixmap)) + (format t "Window ID: ~8x pixmap ID: ~8x~%" + wid (xlib:pixmap-id pixmap)) + (xlib:display-finish-output dpy2) + (format t " --> ~S~%" + (xlib:wm-hints-icon-pixmap (xlib:wm-hints window))) + ;; On the old connection, list the root window children + ;; and the icon pixmap hint to cache their XIDs. + (dolist (w (window-list dpy)) + (let ((id (xlib:window-id w)) (hints (xlib:wm-hints w))) + (when hints + (let ((pm (xlib:wm-hints-icon-pixmap hints))) + (when pm + (format t " W: ~8x -> ~s~%" id pm)))))) + (xlib:close-display dpy2))) + (second-pass (dpy) + ;; Open a fresh connection and create 2 windows. + (xlib:with-open-default-display (dpy2) + (let ((window1 (make-win dpy2)) (id1 (xlib:window-id window1)) + (window2 (make-win dpy2)) (id2 (xlib:window-id window2))) + (format t "Window#1 ID: ~8x Window#2 ID: ~8x~%" id1 id2) + (xlib:display-finish-output dpy2) + ;; On the old connection, list the root window children + ;; and note the second window is erroneously a pixmap + ;; due to too agressive caching in clx. + (dolist (w (window-list dpy)) + (let ((id (xlib:window-id w))) + (cond ((= id1 id) (princ "1 ")) + ((= id2 id) (princ "2 ")) + (t (princ " ")))) + (format t "window: ~s~%" w) + (assert (xlib:window-p w))))))) + (xlib:with-open-display (dpy) + (first-pass dpy) + (second-pass dpy) + (xlib:display-p (xlib:close-display dpy)))) +T + ;; cleanup (flet ((del (s) (makunbound s) (fmakunbound s) (unintern s))) (del '*dpy*) ------------------------------ Message: 6 Date: Wed, 25 Jun 2008 23:05:30 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/clx/new-clx/demos bball.lisp, 1.4, 1.5 bwindow.lisp, 1.3, 1.4 clclock.lisp, 1.1, 1.2 greynetic.lisp, 1.3, 1.4 hanoi.lisp, 1.3, 1.4 koch.lisp, 1.4, 1.5 petal.lisp, 1.3, 1.4 plaid.lisp, 1.3, 1.4 qix.lisp, 1.6, 1.7 recurrence.lisp, 1.3, 1.4 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/modules/clx/new-clx/demos In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv27700/modules/clx/new-clx/demos Modified Files: bball.lisp bwindow.lisp clclock.lisp greynetic.lisp hanoi.lisp koch.lisp petal.lisp plaid.lisp qix.lisp recurrence.lisp Log Message: (with-open-display): define & export Index: recurrence.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/recurrence.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- recurrence.lisp 8 Oct 2007 00:43:32 -0000 1.3 +++ recurrence.lisp 25 Jun 2008 23:05:28 -0000 1.4 @@ -4,12 +4,12 @@ ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. +;;; supporting documentation. ;;; The author provides this software "as is" without express or ;;; implied warranty. ;;; Adapted from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/gui/clx/clx_demo.cl by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -24,7 +24,7 @@ (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture (yf (floor (* (+ 0.7 y) hh )))) (xlib:draw-point win gc xf yf) - (draw-ppict win gc (1- count) + (draw-ppict win gc (1- count) (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) (- 0.21 x) hw @@ -32,30 +32,29 @@ (defun recurrence (&key (point-count 10000) (sleep 4) (x 10) (y 10) (width 700) (height 700)) - "Plot the recurrence + "Plot the recurrence x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 y <- .21 - x As described in a ?? 1983 issue of the Mathematical Intelligencer." - (let* ((dpy (xlib:open-default-display)) - (screen (xlib:display-default-screen dpy)) - (root (xlib:screen-root screen)) - (white-pixel (xlib:screen-white-pixel screen)) - (black-pixel (xlib:screen-black-pixel screen)) - (win (xlib:create-window - :parent root :x x :y y :width width :height height - :event-mask '(:exposure :button-press :button-release - :key-press :key-release) - :background white-pixel)) - (gc (xlib:create-gcontext :drawable win - :background white-pixel - :foreground black-pixel))) - (xlib:map-window win) - (draw-ppict win gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output dpy) - (sleep sleep) - (xlib:free-gcontext gc) - (xlib:unmap-window win) - (xlib:display-finish-output dpy) - (xlib:close-display dpy))) + (xlib:with-open-display (dpy) + (let* ((screen (xlib:display-default-screen dpy)) + (root (xlib:screen-root screen)) + (white-pixel (xlib:screen-white-pixel screen)) + (black-pixel (xlib:screen-black-pixel screen)) + (win (xlib:create-window + :parent root :x x :y y :width width :height height + :event-mask '(:exposure :button-press :button-release + :key-press :key-release) + :background white-pixel)) + (gc (xlib:create-gcontext :drawable win + :background white-pixel + :foreground black-pixel))) + (xlib:map-window win) + (draw-ppict win gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) + (xlib:display-force-output dpy) + (sleep sleep) + (xlib:free-gcontext gc) + (xlib:unmap-window win) + (xlib:display-finish-output dpy)))) (provide "recurrence") Index: clclock.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/clclock.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- clclock.lisp 8 Oct 2007 02:25:49 -0000 1.1 +++ clclock.lisp 25 Jun 2008 23:05:28 -0000 1.2 @@ -1,5 +1,5 @@ ;;; Adapted from http://common-lisp.net/~crhodes/clx by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -26,50 +26,49 @@ (decode-universal-time (get-universal-time)) (format nil "~d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d" ye mo da ho mi se))) -(defun clclock (&key (font "fixed") (duration 100) (time-string :roman) +(defun clclock (&key (font "fixed") (duration 100) (time-string :roman) (background "midnightblue") (foreground "yellow") (x 10) (y 10) (extra-width 20) (extra-height 20)) "Show a digital clock." - (let* ((dpy (xlib:open-default-display)) - (screen (xlib:display-default-screen dpy)) - (white-pixel (xlib:screen-white-pixel screen)) - (colormap (xlib:screen-default-colormap screen)) - (bg (xlib:alloc-color colormap - (xlib:lookup-color colormap background))) - (fg (xlib:alloc-color colormap - (xlib:lookup-color colormap foreground))) - (font-o (xlib:open-font dpy font)) - (time-string-f (ecase time-string - (:roman #'roman-time-string) - (:iso #'iso-time-string)))) - (multiple-value-bind (width height) - (required-size font-o extra-width extra-height) - (let* ((window (xlib:create-window - :parent (xlib:screen-root screen) :x x :y y - :width width :height height :background bg)) - (gcontext (xlib:create-gcontext - :drawable window :fill-style :solid - :background white-pixel - :foreground fg :font font-o)) - (background (xlib:create-gcontext + (xlib:with-open-display (dpy) + (let* ((screen (xlib:display-default-screen dpy)) + (white-pixel (xlib:screen-white-pixel screen)) + (colormap (xlib:screen-default-colormap screen)) + (bg (xlib:alloc-color colormap + (xlib:lookup-color colormap background))) + (fg (xlib:alloc-color colormap + (xlib:lookup-color colormap foreground))) + (font-o (xlib:open-font dpy font)) + (time-string-f (ecase time-string + (:roman #'roman-time-string) + (:iso #'iso-time-string)))) + (multiple-value-bind (width height) + (required-size font-o extra-width extra-height) + (let* ((window (xlib:create-window + :parent (xlib:screen-root screen) :x x :y y + :width width :height height :background bg)) + (gcontext (xlib:create-gcontext :drawable window :fill-style :solid :background white-pixel - :foreground bg :font font-o))) - (xlib:map-window window) - (loop :for count :upfrom 0 :until (and duration (= count duration)) - :for t-string = (funcall time-string-f) - :for string-width = (xlib:text-width gcontext t-string) - :do (xlib:draw-rectangle window background 0 0 width height :fill-p) - (xlib:draw-glyphs window gcontext - (ash (- width string-width extra-width) -1) - (- height (ash extra-height -1)) - t-string) - (xlib:display-force-output dpy) - (sleep 1)) - (xlib:free-colors colormap (list fg bg)) - (xlib:close-font font-o) - (xlib:free-gcontext background) - (xlib:free-gcontext gcontext) - (xlib:unmap-window window) - (xlib:display-force-output dpy) - (xlib:close-display dpy))))) + :foreground fg :font font-o)) + (background (xlib:create-gcontext + :drawable window :fill-style :solid + :background white-pixel + :foreground bg :font font-o))) + (xlib:map-window window) + (loop :for count :upfrom 0 :until (and duration (= count duration)) + :for t-string = (funcall time-string-f) + :for string-width = (xlib:text-width gcontext t-string) + :do (xlib:draw-rectangle window background 0 0 width height :fill-p) + (xlib:draw-glyphs window gcontext + (ash (- width string-width extra-width) -1) + (- height (ash extra-height -1)) + t-string) + (xlib:display-force-output dpy) + (sleep 1)) + (xlib:free-colors colormap (list fg bg)) + (xlib:close-font font-o) + (xlib:free-gcontext background) + (xlib:free-gcontext gcontext) + (xlib:unmap-window window) + (xlib:display-force-output dpy)))))) Index: plaid.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/plaid.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- plaid.lisp 8 Oct 2007 00:43:32 -0000 1.3 +++ plaid.lisp 25 Jun 2008 23:05:28 -0000 1.4 @@ -1,7 +1,7 @@ ;;;; Plaid ;;; Adapted from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/gui/clx/clx_demo.cl by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -18,37 +18,37 @@ (defun plaid (&key (num-iterations 10000) (num-rectangles 10) (sleep 0.1) (x 10) (y 10) (width 101) (height 201)) "Translated from the X11 Plaid Demo written in C by Christopher Hoover." - (let* ((dpy (xlib:open-default-display)) - (screen (xlib:display-default-screen dpy)) - (root (xlib:screen-root screen)) - (white-pixel (xlib:screen-white-pixel screen)) - (black-pixel (xlib:screen-black-pixel screen)) - (window (xlib:create-window - :parent root :width width :height height :x x :y y - :event-mask '(:exposure :button-press :button-release - :key-press :key-release) - :background white-pixel)) - (gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor white-pixel - black-pixel) - :background white-pixel - :foreground black-pixel - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) :initial-element 0)) - (center-x (ash width -1)) - (center-y (ash height -1)) - (niter (truncate num-iterations num-rectangles)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (format t "~&Relax for ~:D second~:P and enjoy...~%" - (round (* sleep niter))) - (xlib:map-window window) - (xlib:display-finish-output dpy) - (dotimes (iter niter) - (dotimes (i num-rectangles) + (xlib:with-open-display (dpy) + (let* ((screen (xlib:display-default-screen dpy)) + (root (xlib:screen-root screen)) + (white-pixel (xlib:screen-white-pixel screen)) + (black-pixel (xlib:screen-black-pixel screen)) + (window (xlib:create-window + :parent root :width width :height height :x x :y y + :event-mask '(:exposure :button-press :button-release + :key-press :key-release) + :background white-pixel)) + (gcontext (xlib:create-gcontext :drawable window + :function boole-c2 + :plane-mask (logxor white-pixel + black-pixel) + :background white-pixel + :foreground black-pixel + :fill-style :solid)) + (rectangles (make-array (* 4 num-rectangles) :initial-element 0)) + (center-x (ash width -1)) + (center-y (ash height -1)) + (niter (truncate num-iterations num-rectangles)) + (x-dir -2) + (y-dir -2) + (x-off 2) + (y-off 2)) + (format t "~&Relax for ~:D second~:P and enjoy...~%" + (round (* sleep niter))) + (xlib:map-window window) + (xlib:display-finish-output dpy) + (dotimes (iter niter) + (dotimes (i num-rectangles) (setf (rect-x rectangles i) (- center-x x-off)) (setf (rect-y rectangles i) (- center-y y-off)) (setf (rect-width rectangles i) (ash x-off 1)) @@ -64,9 +64,8 @@ (xlib:draw-rectangles window gcontext rectangles t) (xlib:display-force-output dpy) (sleep sleep)) - (xlib:free-gcontext gcontext) - (xlib:unmap-window window) - (xlib:display-finish-output dpy) - (xlib:close-display dpy))) + (xlib:free-gcontext gcontext) + (xlib:unmap-window window) + (xlib:display-finish-output dpy)))) (provide "plaid") Index: petal.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/petal.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- petal.lisp 8 Oct 2007 00:43:32 -0000 1.3 +++ petal.lisp 25 Jun 2008 23:05:28 -0000 1.4 @@ -1,7 +1,7 @@ ;;; Petal. ;;; Adapted from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/gui/clx/clx_demo.cl by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -15,9 +15,9 @@ (defconstant vecmax 2880) (defconstant sin-array - '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 + '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 - #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 + #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 @@ -43,16 +43,16 @@ (setq val (- d180 val))) (setq frac (logand val 7)) (setq val (ash val -3)) - ;; + ;; (setq sinlo (if (>= val 90) (svref sin-array 90) (svref sin-array val))) - ;; + ;; (if (< val 90) (setq sinlo (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) -3)))) - ;; + ;; (if neg (- sinlo) sinlo))) @@ -75,7 +75,7 @@ factor cntval needed) (dotimes (i 3) (case i - (0 (setq factor 2 cntval 6)) + (0 (setq factor 2 cntval 6)) (1 (setq factor 3 cntval 2)) (2 (setq factor 5 cntval 1))) (do () @@ -91,69 +91,68 @@ (scalfac-fac 8192) (sleep 0.1) (how-many 100) (style 0) (petal 0) (styinc 2) (petinc 1)) "Draw petals." - (let* ((dpy (xlib:open-default-display)) - (screen (xlib:display-default-screen dpy)) - (root (xlib:screen-root screen)) - (white-pixel (xlib:screen-white-pixel screen)) - (black-pixel (xlib:screen-black-pixel screen)) - (window (xlib:create-window - :parent root :x x :y y :width width :height height - :event-mask '(:exposure :button-press :button-release - :key-press :key-release) - :background white-pixel)) - (veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable window - :foreground black-pixel - :background white-pixel - :line-width 0 :line-style :solid))) - (xlib:map-window window) - (xlib:display-force-output dpy) - (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) + (xlib:with-open-display (dpy) + (let* ((screen (xlib:display-default-screen dpy)) + (root (xlib:screen-root screen)) + (white-pixel (xlib:screen-white-pixel screen)) + (black-pixel (xlib:screen-black-pixel screen)) + (window (xlib:create-window + :parent root :x x :y y :width width :height height + :event-mask '(:exposure :button-press :button-release + :key-press :key-release) + :background white-pixel)) + (veccnt 0) + (nustyle 722) + (nupetal 3) + (scalfac (1+ (floor scalfac-fac (min width height)))) + (ctrx (floor width 2)) + (ctry (floor height 2)) + (tt 0) + (s 0) + (lststyle 0) + (lstpetal 0) + (petstyle 0) + (vectors 0) + (r 0) + (x1 0) + (y1 0) + (x2 0) + (y2 0) + (i 0) + (gc (xlib:create-gcontext :drawable window + :foreground black-pixel + :background white-pixel + :line-width 0 :line-style :solid))) + (xlib:map-window window) + (xlib:display-force-output dpy) + (loop + (when (zerop veccnt) + (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal + style nustyle petstyle (rem (* petal style) d360) + vectors (complete style petal)) + (when continuous + (setq nupetal (+ nupetal petinc) + nustyle (+ nustyle styinc))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (xlib:clear-area window) + (xlib:display-force-output dpy))) (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area window) - (xlib:display-force-output dpy))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line window gc x1 y1 x2 y2) - (xlib:display-force-output dpy))) - (when (> veccnt vectors) - (setq veccnt 0) - (decf how-many) - (sleep sleep) - (when (zerop how-many) (return)))) - (xlib:free-gcontext gc) - (xlib:unmap-window window) - (xlib:display-finish-output dpy) - (xlib:close-display dpy))) + (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 + tt (rem (+ tt style) d360) + s (rem (+ s petstyle) d360) + r (pcos s)) + (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) + y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) + (when (/= i 1) + (xlib:draw-line window gc x1 y1 x2 y2) + (xlib:display-force-output dpy))) + (when (> veccnt vectors) + (setq veccnt 0) + (decf how-many) + (sleep sleep) + (when (zerop how-many) (return)))) + (xlib:free-gcontext gc) + (xlib:unmap-window window) + (xlib:display-finish-output dpy)))) (provide "petal") Index: hanoi.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/hanoi.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- hanoi.lisp 8 Oct 2007 00:43:32 -0000 1.3 +++ hanoi.lisp 25 Jun 2008 23:05:28 -0000 1.4 @@ -1,7 +1,7 @@ ;;;; Hanoi. ;;; Adapted from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/gui/clx/clx_demo.cl by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -41,7 +41,7 @@ ;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" ;;; set to T. Update-Screen forces the display output. -;;; +;;; (defmacro invert-rectangle (x y height width) `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* ,x ,y ,width ,height t)) @@ -215,7 +215,7 @@ ;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. (defun move-n-disks (n start-needle end-needle temp-needle) - "Moves the top N disks from START-NEEDLE to END-NEEDLE. + "Moves the top N disks from START-NEEDLE to END-NEEDLE. Uses TEMP-NEEDLE for temporary storage." (cond ((= n 1) (move-one-disk start-needle end-needle)) @@ -227,39 +227,39 @@ ;;;; Hanoi itself. -(defun hanoi (&key (disks 10) (x 10) (y 10) (width 768) - ((:horizontal-velocity *horizontal-velocity*) *horizontal-velocity*) +(defun hanoi (&key (disks 10) (x 10) (y 10) (width 768) + ((:horizontal-velocity *horizontal-velocity*) + *horizontal-velocity*) ((:vertical-velocity *vertical-velocity*) *vertical-velocity*) ((:height *hanoi-window-height*) 300)) "Towers of Hanoi." - (let* ((*hanoi-display* (xlib:open-default-display)) - (screen (xlib:display-default-screen *hanoi-display*)) - (root (xlib:screen-root screen)) - (white-pixel (xlib:screen-white-pixel screen)) - (black-pixel (xlib:screen-black-pixel screen)) - (*hanoi-window* - (xlib:create-window - :parent root :x x :y y :width width :height *hanoi-window-height* - :event-mask '(:exposure :button-press :button-release - :key-press :key-release) - :background white-pixel)) - (*transfer-height* (- *hanoi-window-height* (* disk-spacing disks))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground white-pixel - :background black-pixel - :fill-style :solid - :function boole-c2)) - (needle-1 (make-needle :position 184)) - (needle-2 (make-needle :position 382)) - (needle-3 (make-needle :position 584))) - (xlib:map-window *hanoi-window*) - (xlib:display-force-output *hanoi-display*) - (dotimes (i disks) - (drop-initial-disk (make-disk :size (* 10 (- disks i))) needle-1)) - (move-n-disks disks needle-1 needle-3 needle-2) - (xlib:free-gcontext *hanoi-gcontext*) - (xlib:unmap-window *hanoi-window*) - (xlib:display-finish-output *hanoi-display*) - (xlib:close-display *hanoi-display*))) + (xlib:with-open-display (*hanoi-display*) + (let* ((screen (xlib:display-default-screen *hanoi-display*)) + (root (xlib:screen-root screen)) + (white-pixel (xlib:screen-white-pixel screen)) + (black-pixel (xlib:screen-black-pixel screen)) + (*hanoi-window* + (xlib:create-window + :parent root :x x :y y :width width :height *hanoi-window-height* + :event-mask '(:exposure :button-press :button-release + :key-press :key-release) + :background white-pixel)) + (*transfer-height* (- *hanoi-window-height* (* disk-spacing disks))) + (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* + :foreground white-pixel + :background black-pixel + :fill-style :solid + :function boole-c2)) + (needle-1 (make-needle :position 184)) + (needle-2 (make-needle :position 382)) + (needle-3 (make-needle :position 584))) + (xlib:map-window *hanoi-window*) + (xlib:display-force-output *hanoi-display*) + (dotimes (i disks) + (drop-initial-disk (make-disk :size (* 10 (- disks i))) needle-1)) + (move-n-disks disks needle-1 needle-3 needle-2) + (xlib:free-gcontext *hanoi-gcontext*) + (xlib:unmap-window *hanoi-window*) + (xlib:display-finish-output *hanoi-display*)))) (provide "hanoi") Index: bwindow.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/bwindow.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- bwindow.lisp 8 Oct 2007 00:43:32 -0000 1.3 +++ bwindow.lisp 25 Jun 2008 23:05:28 -0000 1.4 @@ -1,7 +1,7 @@ ;;;; Bounce window. ;;; Adapted from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/gui/clx/clx_demo.cl by... -;;; Copyright (C) 2007 Sam Steingold <sd...@gn...> +;;; Copyright (C) 2007-2008 Sam Steingold <sd...@gn...> ;;; GPL2 is applicable (in-package :clx-demos) @@ -27,62 +27,61 @@ "Elasticity must be between 0 and 1, got ~S" elasticity) (assert (plusp gravity) (gravity) "Gravity must be positive, got ~S" gravity) - (let* ((dpy (xlib:open-default-display)) - (screen (xlib:display-default-screen dpy)) - (root (xlib:screen-root screen)) - (white-pixel (xlib:screen-white-pixel screen)) - ;; (black-pixel (xlib:screen-black-pixel screen)) - (window (xlib:create-window - :parent root :width width :height height - :event-mask '(:exposure :button-press :button-release - :key-press :key-release) - :x x :y y :background white-pixel)) - (top-of-window-at-bottom (- (xlib:drawable-height root) height)) - (left-of-window-at-right (- (xlib:drawable-width root) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (xlib:map-window window) - (xlib:display-finish-output dpy) - (loop (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output dpy) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output dpy)))) - (xlib:unmap-window window) - (xlib:display-finish-output dpy) - (xlib:close-display dpy))) + (xlib:with-open-display (dpy) + (let* ((screen (xlib:display-default-screen dpy)) + (root (xlib:screen-root screen)) + (white-pixel (xlib:screen-white-pixel screen)) + ;; (black-pixel (xlib:screen-black-pixel screen)) + (window (xlib:create-window + :parent root :width width :height height + :event-mask '(:exposure :button-press :button-release + :key-press :key-release) + :x x :y y :background white-pixel)) + (top-of-window-at-bottom (- (xlib:drawable-height root) height)) + (left-of-window-at-right (- (xlib:drawable-width root) width)) + (y-velocity 0) + (prev-neg-velocity most-negative-fixnum) + (number-problems nil)) + (declare (fixnum top-of-window-at-bottom left-of-window-at-right + y-velocity)) + (xlib:map-window window) + (xlib:display-finish-output dpy) + (loop (when (= prev-neg-velocity 0) (return t)) + (let ((negative-velocity (minusp y-velocity))) + (loop + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output dpy) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y)) + (when (and negative-velocity (>= y-velocity 0)) + (setf negative-velocity nil)) + (let ((next-x (+ x x-velocity))) + (declare (fixnum next-x)) + (when (or (> next-x left-of-window-at-right) + (< next-x 0)) + (setq x-velocity (- (truncate (* elasticity x-velocity))))) + (setq x next-x)) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output dpy)))) + (xlib:unmap-window window) + (xlib:display-finish-output dpy)))) (provide "bwindow") Index: koch.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/demos/koch.lisp,v retrieving revision 1.4 retrieving revision 1.5... [truncated message content] |