| Version 2 (modified by rme, 6 years ago) |
|---|
If you still crave red even after reading the example from the CocoaBridge topic, here's an even more elaborate example.
The point of this example is to demonstrate a non-trivial use of the OpenMCL foreign function interface. (The example is based on pp. 531-540 of Programming with Quartz, by Gelphman and Laden.)
(The (float ... ccl::+cgfloat-zero+) business is necessary because a CGFloat is a single float on 32-bit systems, and a double-float on 64-bit systems, and we want the same source code to work on both.)
(defcallback red-black-ramp (:address info (:array :<CGF>loat) in (:array :<CGF>loat) out :void)
(declare (ignore info))
(let ((w (paref in (:array :<CGF>loat) 0)))
(setf (paref out (:array :<CGF>loat) 0) (float (- 1.0 (abs (- 1.0 (* w 2.0)))) ccl::+cgfloat-zero+)
(paref out (:array :<CGF>loat) 1) (float (- 1.0 (abs (+ (* 1.0 (- 1.0 w)) (* 0.878 w)))) ccl::+cgfloat-zero+)
(paref out (:array :<CGF>loat) 2) (float 0.0 ccl::+cgfloat-zero+)
(paref out (:array :<CGF>loat) 3) (float 1.0 ccl::+cgfloat-zero+))))
(defun rgb-function (eval-fn)
(let* ((zero (float 0.0 ccl::+cgfloat-zero+))
(one (float 1.0 ccl::+cgfloat-zero+)))
(rlet ((domain (:array :<CGF>loat 2))
(range (:array :<CGF>loat 8)))
;; Shadings parameterize the input between 0 (the starting point
;; of the shading) and 1 (the ending point of the shading).
(setf (paref domain (:array :<CGF>loat) 0) zero
(paref domain (:array :<CGF>loat) 1) one)
;; The range of the output colors. For an RGB color space, there
;; are four (start, end) pairs: one for each R, G, B, A component.
(setf
;; red
(paref range (:array :<CGF>loat) 0) zero
(paref range (:array :<CGF>loat) 1) one
;; green
(paref range (:array :<CGF>loat) 2) zero
(paref range (:array :<CGF>loat) 3) one
;; blue
(paref range (:array :<CGF>loat) 4) zero
(paref range (:array :<CGF>loat) 5) one
;; alpha
(paref range (:array :<CGF>loat) 6) zero
(paref range (:array :<CGF>loat) 7) one)
(rlet ((callbacks :<CGF>unction<C>allbacks))
(setf (pref callbacks :<CGF>unction<C>allbacks.version) 0
(pref callbacks :<CGF>unction<C>allbacks.release<I>nfo) +null-ptr+
(pref callbacks :<CGF>unction<C>allbacks.evaluate) eval-fn)
(#_CGFunctionCreate +null-ptr+ 1 domain 4 range callbacks)))))
(defclass gradient-view (ns:ns-view)
()
(:metaclass ns:+ns-object))
(objc:defmethod (#/drawRect: :void) ((self gradient-view) (rect :<NSR>ect))
(#_NSRectFill (#/bounds self))
(let* ((extend-start 1)
(extend-end 1)
(color-space (#_CGColorSpaceCreateDeviceRGB))
(fn (rgb-function red-black-ramp))
(shading nil)
(context (#/graphicsPort (#/currentContext ns:ns-graphics-context))))
(let ((p0 (ns:make-ns-point 20 20))
(p1 (ns:make-ns-point 100 280)))
(setq shading (#_CGShadingCreateAxial color-space p0 p1 fn
extend-start extend-end)))
(#_CFRelease color-space)
(#_CFRelease fn)
(#_CGContextDrawShading context shading)
(#_CGShadingRelease shading)))
(defun show-gradient-window ()
(ccl::with-autorelease-pool
(let* ((rect (ns:make-ns-rect 0 0 300 300))
(w (make-instance 'ns:ns-window
:with-content-rect rect
:style-mask (logior #$NSTitledWindowMask
#$NSClosableWindowMask
#$NSMiniaturizableWindowMask)
:backing #$NSBackingStoreBuffered
:defer t)))
(#/setTitle: w #@"Red Gradient")
(#/setContentView: w (#/autorelease (make-instance 'gradient-view)))
(#/center w)
(#/orderFront: w nil)
(#/contentView w))))
Load the file containing these forms, evaluate (show-gradient-window) and you'll see a window with a red gradient in it.
