5 Sep 13:16
y-or-n-dialog contribution
From: Arthur W Cater <arthur.cater <at> ucd.ie>
Subject: y-or-n-dialog contribution
Newsgroups: gmane.lisp.openmcl.devel
Date: 2008-09-05 11:16:45 GMT
Subject: y-or-n-dialog contribution
Newsgroups: gmane.lisp.openmcl.devel
Date: 2008-09-05 11:16:45 GMT
Here's a y-or-n-dialog function using cocoa calls. Maybe there was something like it already but I failed to find it.
Suggested improvements most welcome: I am just learning ...
(in-package :easygui)
(defun y-or-n-dialog (message)
(let* (dialog content
(app (#/sharedApplication ns:ns-application))
(yes (make-instance 'ns:ns-button))
(no (make-instance 'ns:ns-button))
(query (make-instance 'ns:ns-text-field)))
(flet ((buttonize (button text x action)
(dcc (#/setTitle: button text))
(dcc (#/setBezelStyle: button #$NSRoundedBezelStyle))
(dcc (#/sizeToFit button))
(if (< x 0)
(let ((left (- 0 x (ns:ns-rect-width (dcc (#/bounds button))))))
(dcc (#/setFrameOrigin: button (ns:make-ns-point left 9))))
(dcc (#/setFrameOrigin: button (ns:make-ns-point x 9))))
(dcc (#/addSubview: content button))
(dcc (#/setTarget: button app))
(dcc (#/setAction: button action))))
(dcc (#/setStringValue: query message))
(dcc (#/setFrameOrigin: query (ns:make-ns-point 9 48)))
(dcc (#/sizeToFit query))
(let* ((querybounds (dcc (#/bounds query)))
(width (max 100.0 (+ 18.0 (ns:ns-rect-width querybounds))))
(rect (ns:make-ns-rect
*window-position-default-x*
*window-position-default-y*
width
(max 90.0 (+ 57.0 (ns:ns-rect-height querybounds))))))
(setf dialog (make-instance 'ns:ns-window
:with-content-rect rect
:style-mask (logior #$NSBorderlessWindowMask #$NSTexturedBackgroundWindowMask)
:backing #$NSBackingStoreBuffered ; TODO? Copied from ccl:examples/cocoa/easygui/views.lisp
:defer nil)
content (#/contentView dialog))
(buttonize yes "Yes" 9 ( <at> selector #/stopModal))
(buttonize no "No" (- 9 width) ( <at> selector #/abortModal)))
(dcc (#/addSubview: content query))
(prog1
(eq #$NSRunStoppedResponse (dcc (#/runModalForWindow: app dialog)))
(#/close dialog)))))
_______________________________________________ Openmcl-devel mailing list Openmcl-devel <at> clozure.com http://clozure.com/mailman/listinfo/openmcl-devel
RSS Feed