Version 2 (modified by rme, 6 years ago) (diff)


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.
       ;; 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 ()
   (let* ((rect (ns:make-ns-rect 0 0 300 300))
	  (w (make-instance 'ns:ns-window
			    :with-content-rect rect
			    :style-mask (logior #$NSTitledWindowMask
			    :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.