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 (gui:execute-in-gui #'(lambda () (show-gradient-window)) and you'll see a window with a red gradient in it.

Last modified 4 years ago Last modified on Oct 20, 2017, 8:44:52 PM