[clg] / examples / testcairo.lisp

;; This file contains the cairo C snippets translated to lisp 
;; See http://cairographics.org/samples/

#+sbcl(require :gtk)
#+cmu(asdf:oos 'asdf:load-op :gtk)
#+sbcl(require :cairo)
#+cmu(asdf:oos 'asdf:load-op :cairo)

;;#+sbcl(require :rsvg)
;;#+cmu(asdf:oos 'asdf:load-op :avg-cairo)

(defpackage "TESTCAIRO"
  (:use "COMMON-LISP" "GTK")
  (:export "CREATE-TESTS"))

(in-package "TESTCAIRO")

(declaim (inline deg-to-rad))
(defun deg-to-rad (deg)
  (* deg (/ pi 180)))

(declaim (inline rad-to-deg))
(defun rad-to-deg (rad)
  (/ (* rad 180) pi))


(defvar *snippets* ())


(defmacro define-snippet (name (cr) &body body)
  (let ((widget (make-symbol "WIDGET"))
	(window (make-symbol "WINDOW"))
	(pointer (make-symbol "POINTER")))
    `(let ((,window nil))
       (setq *snippets* (pushnew ',name *snippets*))
       (defun ,name ()
	 (if (not ,window)
	     (let ((,widget (make-instance 'drawing-area)))
	       (setq ,window
	        (make-instance 'window 
		 :width-request 300 :height-request 300 
		 :title ,(string-downcase name)
		 :visible t :child ,widget))
	       (signal-connect ,window 'destroy 
                #'(lambda () (setq ,window nil)))
	       (signal-connect ,widget 'expose-event
		#'(lambda (,pointer)
		    (declare (ignore ,pointer))
		    (let ((,cr (gdk:cairo-create (widget-window ,widget))))
		      (multiple-value-bind (width height) 
			  (widget-get-size-allocation ,widget)
			(cairo:scale ,cr width height))
		      (setf (cairo:line-width ,cr) 0.04)
		      ,@body)))
	       (widget-show-all ,window))
	   (widget-destroy ,window))))))


(defun arc-helper-lines (cr xc yc radius angle1 angle2)
  (cairo:set-source-color cr 1 0.2 0.2 0.6)
  (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360))
  (cairo:fill cr)
  (setf (cairo:line-width cr) 0.03)
  (cairo:move-to cr xc yc)
  (cairo:rel-line-to cr (* radius (cos angle1)) (* radius (sin angle1)))
  (cairo:stroke cr)
  (cairo:move-to cr xc yc)
  (cairo:rel-line-to cr (* radius (cos angle2)) (* radius (sin angle2)))
  (cairo:stroke cr))

(define-snippet arc (cr)
  (let ((xc 0.5)
	(yc 0.5)
	(radius 0.4)
	(angle1 (deg-to-rad 45.0))
	(angle2 (deg-to-rad 180.0)))

    (cairo:with-context (cr)
      (setf (cairo:line-cap cr) :round)
      (cairo:arc cr xc yc radius angle1 angle2)
      (cairo:stroke cr))

    (arc-helper-lines cr xc yc radius angle1 angle2)))

(define-snippet arc-negative (cr)
  (let ((xc 0.5)
	(yc 0.5)
	(radius 0.4)
	(angle1 (deg-to-rad 45.0))
	(angle2 (deg-to-rad 180.0)))

    (cairo:with-context (cr)
      (setf (cairo:line-cap cr) :round)
      (cairo:arc-negative cr xc yc radius angle1 angle2)
      (cairo:stroke cr))

    (arc-helper-lines cr xc yc radius angle1 angle2)))


(define-snippet clip (cr)
  (cairo:circle cr 0.5 0.5 0.3)
  (cairo:clip cr)

  (cairo:new-path cr) ; current path is not consumed by cairo:clip
  (cairo:rectangle cr 0 0 1 1)
  (cairo:fill cr)
  (cairo:set-source-color cr 0 1 0)
  (cairo:move-to cr 0 0)
  (cairo:line-to cr 1 1)
  (cairo:move-to cr 1 0)
  (cairo:line-to cr 0 1)
  (cairo:stroke cr))


(define-snippet clip-image (cr)
  (cairo:circle cr 0.5 0.5 0.3)
  (cairo:clip cr)
  (cairo:new-path cr)

  (let ((image (cairo:image-surface-create-from-png 
		#p"clg:examples;romedalen.png")))

    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image)))
      (cairo:scale cr (/ 1.0 width) (/ 1.0 height)))

    (cairo:set-source-surface cr image 0 0)
    (cairo:paint cr)))

(define-snippet clip-rectangle (cr)
  (cairo:new-path cr)
  (cairo:move-to cr 0.25 0.25)
  (cairo:line-to cr 0.25 0.75)
  (cairo:line-to cr 0.75 0.75)
  (cairo:line-to cr 0.75 0.25)
  (cairo:line-to cr 0.25 0.25)
  (cairo:close-path cr)

  (cairo:clip cr)

  (cairo:move-to cr 0 0)
  (cairo:line-to cr 1 1)
  (cairo:stroke cr))


;; (define-snippet curve-rectangle (cr)
;;   (let ((x0 0.1)
;; 	(y0 0.1)
;; 	(width 0.8)
;; 	(height 0.8)
;; 	(radius 0.4))
;;     (unless (and (zerop width) (zerop height))
;;       (let ((x1 (+ x0 width))
;; 	    (y1 (+ y0 height)))
;; 	(cond
;; 	 ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius))
;; 	  (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
;; 	  (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
;; 	  (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
;; 	  (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
;; 	  (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
;; 	 ((< (* 0.5 width) radius)
;; 	  (cairo:move-to  cr x0 (+ y0 radius))
;; 	  (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
;; 	  (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
;; 	  (cairo:line-to cr x1  (- y1 radius))
;; 	  (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
;; 	  (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))
;; 	 ((< (* 0.5 height) radius)
;; 	  (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
;; 	  (cairo:curve-to cr x0  y0 x0  y0 (+ x0 radius) y0)
;; 	  (cairo:line-to cr (- x1 radius) y0)
;; 	  (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
;; 	  (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
;; 	  (cairo:line-to cr (+ x0 radius) y1)
;; 	  (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
;; 	 (t
;; 	  (cairo:move-to cr x0 (+ y0 radius))
;; 	  (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
;; 	  (cairo:line-to cr (- x1 radius) y0)
;; 	  (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
;; 	  (cairo:line-to cr x1 (- y1 radius))
;; 	  (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
;; 	  (cairo:line-to cr (+ x0 radius) y1)
;; 	  (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))))
;; 	(cairo:close-path cr)

;; 	(cairo:set-source-color cr 0.5 0.5 1.0)
;; 	(cairo:fill cr t)
;;  	(cairo:set-source-color cr 0.5 0.0 0.0 0.5)
;;  	(cairo:stroke cr)))))


(define-snippet curve-to (cr)
  (let ((x 0.1) (y 0.5)
	(x1 0.4) (y1 0.9)
	(x2 0.6) (y2 0.1)
	(x3 0.9) (y3 0.5))

    (cairo:move-to cr x y)
    (cairo:curve-to cr x1 y1 x2 y2 x3 y3)

    (cairo:stroke cr)

    (cairo:set-source-color cr 1 0.2 0.2 0.6)
    (setf (cairo:line-width cr) 0.03)
    (cairo:move-to cr x y)
    (cairo:line-to cr x1 y1)
    (cairo:move-to cr x2 y2)
    (cairo:line-to cr x3 y3)
    (cairo:stroke cr)))


(define-snippet dash (cr)
  (let ((dashes #(0.20 0.05 0.05 0.05))
	(offset -0.2))
    (cairo:set-dash cr dashes offset)
    (cairo:move-to cr 0.5 0.1)
    (cairo:line-to cr 0.9 0.9)
    (cairo:rel-line-to cr -0.4 0.0)
    (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
    (cairo:stroke cr)))


(defun fill-and-stroke-common (cr)
  (cairo:move-to cr 0.5 0.1)
  (cairo:line-to cr 0.9 0.9)
  (cairo:rel-line-to cr -0.4 0.0)
  (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
  (cairo:close-path cr))
 

(define-snippet fill-and-stroke2 (cr)
  (fill-and-stroke-common cr)
  (cairo:move-to cr 0.25 0.1)
  (cairo:rel-line-to cr 0.2 0.2)
  (cairo:rel-line-to cr -0.2 0.2)
  (cairo:rel-line-to cr -0.2 -0.2)
  (cairo:close-path cr)

  (cairo:set-source-color cr 0 0 1)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0 0 0)
  (cairo:stroke cr))


(define-snippet fill-and-stroke (cr)
  (fill-and-stroke-common cr)

  (cairo:set-source-color cr 0 0 1)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0 0 0)
  (cairo:stroke cr))


(define-snippet gradient (cr)
  (let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0)))
    (cairo:pattern-add-color-stop pattern 1 0 0 0 1)
    (cairo:pattern-add-color-stop pattern 0 1 1 1 1)
    (cairo:rectangle cr 0 0 1 1)
    (setf (cairo:source cr) pattern)
    (cairo:fill cr))
  (let ((pattern (cairo:pattern-create-radial 0.45 0.4 0.1 0.4 0.4 0.5)))
    (cairo:pattern-add-color-stop pattern 0 1 1 1 1)
    (cairo:pattern-add-color-stop pattern 1 0 0 0 1)
    (setf (cairo:source cr) pattern)
    (cairo:circle cr 0.5 0.5 0.3)
    (cairo:fill cr)))


(define-snippet image (cr)
  (let ((image (cairo:image-surface-create-from-png 
		#p"clg:examples;romedalen.png")))
    (cairo:translate cr 0.5 0.5)
    (cairo:rotate cr (deg-to-rad 45))
    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image)))
      (cairo:scale cr (/ 1.0 width) (/ 1.0 height))  
      (cairo:translate cr (* -0.5 width) (* -0.5 height)))
    (cairo:set-source-surface cr image 0 0)
    (cairo:paint cr)))

    
(define-snippet image-pattern (cr)
  (let* ((image (cairo:image-surface-create-from-png 
		 #p"clg:examples;romedalen.png"))
	 (pattern (cairo:pattern-create-for-surface image)))
    (setf (cairo:pattern-extend pattern) :repeat)    
    (cairo:translate cr 0.5 0.5)
    (cairo:rotate cr (deg-to-rad 45))
    (cairo:scale cr (/ 1.0 (sqrt 2)) (/ 1.0 (sqrt 2)))  
    (cairo:translate cr -0.5 -0.5)
    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image))
	  (matrix (make-instance 'cairo:matrix)))
      (cairo:matrix-init-scale matrix (* 5 width) (* 5 height))
      (setf (cairo:pattern-matrix pattern) matrix))
    (setf (cairo:source cr) pattern)
    (cairo:rectangle cr 0.0 0.0 1.0 1.0)
    (cairo:fill cr)))


;; (defun snippet-set-bg-svg (cr filename)
;;   (let ((handle (make-instance 'rsvg:handle :filename filename)))
;;     (cairo:with-context (cr)
;;       (with-slots (rsvg:width rsvg:height) (rsvg:handle-dimensions handle)
;; 	(cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height))
;; 	(rsvg:cairo-render cr handle)))))

;; (define-snippet librsvg (cr)
;;   (snippet-set-bg-svg cr "clg:examples;home.svg"))


(defmacro define-operator-snippet (operator)
  (let ((name (intern (format nil "OPERATOR-~A" operator))))
    `(define-snippet ,name (cr)
       (snippet-set-bg-svg cr "clg:examples;freedesktop.svg")
       (setf (cairo:operator cr) ,operator)
       
       (cairo:set-source-color cr 1.0 0.0 0.0 0.5)
       (cairo:rectangle cr 0.2 0.2 0.5 0.5)
       (cairo:fill)
       
       (cairo:set-source-color cr 0.0 1.0 0.0)
       (cairo:rectangle cr 0.4 0.4 0.4 0.4)
       (cairo:fill)
       
       (cairo:set-source-color cr 0.0 0.0 1.0)
       (cairo:rectangle cr 0.6 0.6 0.3 0.3)
       (cairo:fill))))

;; (define-operator-snippet :add)
;; (define-operator-snippet :atop)
;; (define-operator-snippet :atop-reverse)
;; (define-operator-snippet :in)
;; (define-operator-snippet :in-reverse)
;; (define-operator-snippet :out)
;; (define-operator-snippet :out-reverse)
;; (define-operator-snippet :over)
;; (define-operator-snippet :over-reverse)
;; (define-operator-snippet :saturate)
;; (define-operator-snippet :xor)

      
(define-snippet path (cr)
  (cairo:move-to cr 0.5 0.1)
  (cairo:line-to cr 0.9 0.9)
  (cairo:rel-line-to cr -0.4 0.0)
  (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
  (cairo:stroke cr))


;; (let ((path))
;;   (define-snippet pattern-fill (cr)
;;     (let ((spikes 10)
;; 	  (text "KAPOW!"))
;;       (unless path
;; 	(let ((x-fuzz 0.08)
;; 	      (y-fuzz 0.08)
;; 	      (x-inner-radius 0.3)
;; 	      (y-inner-radius 0.2)
;; 	      (x-outer-radius 0.45)
;; 	      (y-outer-radius 0.35))
;; 	  (setq path (make-array (* 2 spikes)))
;; 	  (loop
;; 	   for i from 0 below (* 2 spikes)
;; 	   do (multiple-value-bind (x-radius y-radius)
;; 		  (if (evenp i)
;; 		      (values x-inner-radius y-inner-radius)
;; 		    (values x-outer-radius y-outer-radius))
;; 		(setf 
;; 		 (svref path i)
;; 		 (cons
;; 		  (+ 0.5 (* (cos (* pi (/ i spikes))) x-radius) 
;; 		     (* (random 1.0) x-fuzz))
;; 		  (+ 0.5 (* (sin (* pi (/ i spikes))) y-radius)
;; 		     (* (random 1.0) y-fuzz))))))))
      
;;       (setf (cairo:line-width cr) 0.01)
;;       (cairo:move-to cr (car (svref path 0)) (cdr (svref path 0)))
;;       (loop
;;        for i from 1 below (* 2 spikes)
;;        do (cairo:line-to cr (car (svref path i)) (cdr (svref path i))))
;;       (cairo:close-path cr)
;;       (cairo:stroke cr)
;;       (cairo:move-to cr 
;;        (car (svref path (1- spikes))) (cdr (svref path (1- spikes))))

;;       (cairo:select-font-face cr "Sans" :normal :bold)
;;       (time (cairo:text-path cr text))
;;       (cairo:set-source-color cr 1.0 1.0 0.5)
;;       (cairo:fill cr)

;;       (cairo:set-font-size cr 0.2)
;;       (let* ((extents (cairo:text-extents cr text))
;; 	     (x (- 0.5 (+ (* 0.5 (cairo:text-extents-width extents)) (cairo:text-extents-x-bearing extents))))
;; 	     (y (- 0.5 (+ (* 0.5 (cairo:text-extents-height extents)) (cairo:text-extents-y-bearing extents)))))

;; 	(cairo:move-to cr x y)
;; 	(cairo:text-path cr text)
;; 	(cairo:set-source-color cr 0 0 0)
;; 	(cairo:stroke cr)))))


(define-snippet set-line-cap (cr)
  (setf (cairo:line-width cr) 0.12)
  (setf (cairo:line-cap cr) :butt)
  (cairo:move-to cr 0.25 0.2)
  (cairo:line-to cr 0.25 0.8)
  (cairo:stroke cr)
  (setf (cairo:line-cap cr) :round)
  (cairo:move-to cr 0.5 0.2)
  (cairo:line-to cr 0.5 0.8)
  (cairo:stroke cr)
  (setf (cairo:line-cap cr) :square)
  (cairo:move-to cr 0.75 0.2)
  (cairo:line-to cr 0.75 0.8)
  (cairo:stroke cr)

  ;; draw helping lines
  (cairo:set-source-color cr 1 0.2 0.2)
  (setf (cairo:line-width cr) 0.01)
  (cairo:move-to cr 0.25 0.2)
  (cairo:line-to cr 0.25 0.8)
  (cairo:move-to cr 0.5 0.2) 
  (cairo:line-to cr 0.5 0.8)
  (cairo:move-to cr 0.75 0.2)
  (cairo:line-to cr 0.75 0.8)
  (cairo:stroke cr))


(define-snippet set-line-join (cr)
  (setf (cairo:line-width cr) 0.16)
  (cairo:move-to cr 0.3 0.33)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :miter) ; default
  (cairo:stroke cr)

  (cairo:move-to cr 0.3 0.63)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :bevel)
  (cairo:stroke cr)
		
  (cairo:move-to cr 0.3 0.93)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :round)
  (cairo:stroke cr))


(define-snippet text (cr)
   (cairo:select-font-face cr "Sans" :normal :bold)
;;   ;(setf (cairo:font-size cr) 0.35)
   (cairo:set-font-size cr 0.35)

   (cairo:move-to cr 0.04 0.53)
   (cairo:show-text cr "Hello")

  (cairo:move-to cr 0.27 0.65)
  (cairo:text-path cr "void")
  (cairo:set-source-color cr 0.5 0.5 1)
  (cairo:fill cr t)

  (cairo:set-source-color cr 0 0 0)
  (setf (cairo:line-width cr) 0.01)
  (cairo:stroke cr)

  ;; draw helping lines
  (cairo:set-source-color cr 1 0.2 0.2  0.6)
  (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360))
  (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360))
  (cairo:fill cr))


(define-snippet text-align-center (cr)
  (let ((text "cairo"))
    (cairo:select-font-face cr "Sans" :normal :normal)
    (cairo:set-font-size cr 0.2)

    (let* ((extents (cairo:text-extents cr text))
	   (x (- 0.5 (+ (/ (cairo:text-extents-width extents) 2) (cairo:text-extents-x-bearing extents))))
	   (y (- 0.5 (+ (/ (cairo:text-extents-height extents) 2) (cairo:text-extents-y-bearing extents)))))
      (cairo:move-to cr x y)
      (cairo:show-text cr text)

      ;; draw helping lines
      (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
      (cairo:circle cr x y 0.05)
      (cairo:fill cr)
      (cairo:move-to cr 0.5 0.0)
      (cairo:rel-line-to cr 0.0 1.0)
      (cairo:move-to cr 0.0 0.5)
      (cairo:rel-line-to cr 1.0 0.0)
      (cairo:stroke cr))))

(define-snippet text-extents (cr)
  (let ((text "cairo"))
    (cairo:select-font-face cr "Sans" :normal :normal)
    (cairo:set-font-size cr 0.4)

    (let* ((extents (cairo:text-extents cr text))
	   (x 0.1)
	   (y 0.6))
      (cairo:move-to cr x y)
      (cairo:show-text cr text)

      ;; draw helping lines
      (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
      (cairo:circle cr x y 0.05)
      (cairo:fill cr)
      (cairo:move-to cr x y)
      (cairo:rel-line-to cr 0 (- (cairo:text-extents-height extents)))
      (cairo:rel-line-to cr (cairo:text-extents-width extents) 0)
      (cairo:rel-line-to cr 
       (cairo:text-extents-x-bearing extents)
       (- (cairo:text-extents-y-bearing extents)))
      (cairo:stroke cr))))


(defun create-tests ()
;;   (rc-parse "clg:examples;testgtkrc2")
;;   (rc-parse "clg:examples;testgtkrc")

  (let* ((main-window (make-instance 'window
		       :title "testcairo.lisp" :name "main-window"
		       :default-width 200 :default-height 400
		       :allow-grow t :allow-shrink nil))
	 (scrolled-window (make-instance 'scrolled-window
			   :hscrollbar-policy :automatic 
			   :vscrollbar-policy :automatic
			   :border-width 10))
	 (close-button (make-instance 'button 
		        :label "close" :can-default t
			:signal (list 'clicked #'widget-destroy 
			         :object main-window))))

    (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
      (setf 
       (window-icon main-window) 
       (gdk:pixbuf-add-alpha icon t 254 254 252)))

    ;; Main box
    (make-instance 'v-box
     :parent main-window
     :child-args '(:expand nil)
     :child (list (make-instance 'label :label (gtk-version)) :fill nil)
     :child (list (make-instance 'label :label (clg-version)) :fill nil)
     :child (list (make-instance 'label 			  
		   :label #-cmu(format nil "~A (~A)" 
			        (lisp-implementation-type)
				(lisp-implementation-version))
		          ;; The version string in CMUCL is far too long
		          #+cmu(lisp-implementation-type))
		  :fill nil)
     :child (list scrolled-window :expand t)
     :child (make-instance 'h-separator)
     :child (make-instance 'v-box 
	     :homogeneous nil :spacing 10 :border-width 10 
	     :child close-button))

    (let ((content-box 
	   (make-instance 'v-box
	    :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
	    :children (mapcar #'(lambda (snippet)
				  (create-button (string-downcase snippet) snippet))
			      (sort *snippets* #'string<)))))
      (scrolled-window-add-with-viewport scrolled-window content-box))
    
    (widget-grab-focus close-button)
    (widget-show-all main-window)
    main-window))


(clg-init)
;;(rsvg:init)
Commit	Line	Data
1ed0a2c5	1	;; This file contains the cairo C snippets translated to lisp
	2	;; See http://cairographics.org/samples/
	3
	4	#+sbcl(require :gtk)
	5	#+cmu(asdf:oos 'asdf:load-op :gtk)
	6	#+sbcl(require :cairo)
	7	#+cmu(asdf:oos 'asdf:load-op :cairo)
	8
	9	;;#+sbcl(require :rsvg)
	10	;;#+cmu(asdf:oos 'asdf:load-op :avg-cairo)
	11
	12	(defpackage "TESTCAIRO"
	13	(:use "COMMON-LISP" "GTK")
	14	(:export "CREATE-TESTS"))
	15
	16	(in-package "TESTCAIRO")
	17
	18	(declaim (inline deg-to-rad))
	19	(defun deg-to-rad (deg)
	20	(* deg (/ pi 180)))
	21
	22	(declaim (inline rad-to-deg))
	23	(defun rad-to-deg (rad)
	24	(/ (* rad 180) pi))
	25
	26
	27	(defvar snippets ())
	28
	29
	30	(defmacro define-snippet (name (cr) &body body)
	31	(let ((widget (make-symbol "WIDGET"))
	32	(window (make-symbol "WINDOW"))
	33	(pointer (make-symbol "POINTER")))
	34	`(let ((,window nil))
	35	(setq snippets (pushnew ',name snippets))
	36	(defun ,name ()
	37	(if (not ,window)
	38	(let ((,widget (make-instance 'drawing-area)))
	39	(setq ,window
	40	(make-instance 'window
	41	:width-request 300 :height-request 300
	42	:title ,(string-downcase name)
	43	:visible t :child ,widget))
	44	(signal-connect ,window 'destroy
	45	#'(lambda () (setq ,window nil)))
	46	(signal-connect ,widget 'expose-event
	47	#'(lambda (,pointer)
	48	(declare (ignore ,pointer))
	49	(let ((,cr (gdk:cairo-create (widget-window ,widget))))
	50	(multiple-value-bind (width height)
	51	(widget-get-size-allocation ,widget)
	52	(cairo:scale ,cr width height))
	53	(setf (cairo:line-width ,cr) 0.04)
	54	,@body)))
	55	(widget-show-all ,window))
	56	(widget-destroy ,window))))))
	57
	58
	59
	60
	61	(defun arc-helper-lines (cr xc yc radius angle1 angle2)
	62	(cairo:set-source-color cr 1 0.2 0.2 0.6)
	63	(cairo:arc cr xc yc 0.05 0 (deg-to-rad 360))
	64	(cairo:fill cr)
65	(setf (cairo:line-width cr) 0.03)
66	(cairo:move-to cr xc yc)
67	(cairo:rel-line-to cr (* radius (cos angle1)) (* radius (sin angle1)))
68	(cairo:stroke cr)
69	(cairo:move-to cr xc yc)
70	(cairo:rel-line-to cr (* radius (cos angle2)) (* radius (sin angle2)))
71	(cairo:stroke cr))
72
73	(define-snippet arc (cr)
74	(let ((xc 0.5)
75	(yc 0.5)
76	(radius 0.4)
77	(angle1 (deg-to-rad 45.0))
78	(angle2 (deg-to-rad 180.0)))
79
80	(cairo:with-context (cr)
81	(setf (cairo:line-cap cr) :round)
82	(cairo:arc cr xc yc radius angle1 angle2)
83	(cairo:stroke cr))
84
85	(arc-helper-lines cr xc yc radius angle1 angle2)))
86
87	(define-snippet arc-negative (cr)
88	(let ((xc 0.5)
89	(yc 0.5)
90	(radius 0.4)
91	(angle1 (deg-to-rad 45.0))
92	(angle2 (deg-to-rad 180.0)))
93
94	(cairo:with-context (cr)
95	(setf (cairo:line-cap cr) :round)
96	(cairo:arc-negative cr xc yc radius angle1 angle2)
97	(cairo:stroke cr))
98
99	(arc-helper-lines cr xc yc radius angle1 angle2)))
100
101
102	(define-snippet clip (cr)
103	(cairo:circle cr 0.5 0.5 0.3)
104	(cairo:clip cr)
105
106	(cairo:new-path cr) ; current path is not consumed by cairo:clip
107	(cairo:rectangle cr 0 0 1 1)
108	(cairo:fill cr)
109	(cairo:set-source-color cr 0 1 0)
110	(cairo:move-to cr 0 0)
111	(cairo:line-to cr 1 1)
112	(cairo:move-to cr 1 0)
113	(cairo:line-to cr 0 1)
114	(cairo:stroke cr))
115
116
117	(define-snippet clip-image (cr)
118	(cairo:circle cr 0.5 0.5 0.3)
119	(cairo:clip cr)
120	(cairo:new-path cr)
121
122	(let ((image (cairo:image-surface-create-from-png
123	#p"clg:examples;romedalen.png")))
124
125	(let ((width (cairo:surface-width image))
126	(height (cairo:surface-height image)))
127	(cairo:scale cr (/ 1.0 width) (/ 1.0 height)))
128
129	(cairo:set-source-surface cr image 0 0)
130	(cairo:paint cr)))
131
132	(define-snippet clip-rectangle (cr)
133	(cairo:new-path cr)
134	(cairo:move-to cr 0.25 0.25)
135	(cairo:line-to cr 0.25 0.75)
136	(cairo:line-to cr 0.75 0.75)
137	(cairo:line-to cr 0.75 0.25)
138	(cairo:line-to cr 0.25 0.25)
139	(cairo:close-path cr)
140
141	(cairo:clip cr)
142
143	(cairo:move-to cr 0 0)
144	(cairo:line-to cr 1 1)
145	(cairo:stroke cr))
146
147
148	;; (define-snippet curve-rectangle (cr)
149	;; (let ((x0 0.1)
150	;; (y0 0.1)
151	;; (width 0.8)
152	;; (height 0.8)
153	;; (radius 0.4))
154	;; (unless (and (zerop width) (zerop height))
155	;; (let ((x1 (+ x0 width))
156	;; (y1 (+ y0 height)))
157	;; (cond
158	;; ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius))
159	;; (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
160	;; (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
161	;; (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
162	;; (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
163	;; (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
164	;; ((< (* 0.5 width) radius)
165	;; (cairo:move-to cr x0 (+ y0 radius))
166	;; (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
167	;; (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
168	;; (cairo:line-to cr x1 (- y1 radius))
169	;; (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
170	;; (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))
171	;; ((< (* 0.5 height) radius)
172	;; (cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
173	;; (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
174	;; (cairo:line-to cr (- x1 radius) y0)
175	;; (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
176	;; (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
177	;; (cairo:line-to cr (+ x0 radius) y1)
178	;; (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
179	;; (t
180	;; (cairo:move-to cr x0 (+ y0 radius))
181	;; (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
182	;; (cairo:line-to cr (- x1 radius) y0)
183	;; (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
184	;; (cairo:line-to cr x1 (- y1 radius))
185	;; (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
186	;; (cairo:line-to cr (+ x0 radius) y1)
187	;; (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))))
188	;; (cairo:close-path cr)
189
190	;; (cairo:set-source-color cr 0.5 0.5 1.0)
191	;; (cairo:fill cr t)
192	;; (cairo:set-source-color cr 0.5 0.0 0.0 0.5)
193	;; (cairo:stroke cr)))))
194
195
196
197	(define-snippet curve-to (cr)
198	(let ((x 0.1) (y 0.5)
199	(x1 0.4) (y1 0.9)
200	(x2 0.6) (y2 0.1)
201	(x3 0.9) (y3 0.5))
202
203	(cairo:move-to cr x y)
204	(cairo:curve-to cr x1 y1 x2 y2 x3 y3)
205
206	(cairo:stroke cr)
207
208	(cairo:set-source-color cr 1 0.2 0.2 0.6)
209	(setf (cairo:line-width cr) 0.03)
210	(cairo:move-to cr x y)
211	(cairo:line-to cr x1 y1)
212	(cairo:move-to cr x2 y2)
213	(cairo:line-to cr x3 y3)
214	(cairo:stroke cr)))
215
216
217	(define-snippet dash (cr)
218	(let ((dashes #(0.20 0.05 0.05 0.05))
219	(offset -0.2))
220	(cairo:set-dash cr dashes offset)
221	(cairo:move-to cr 0.5 0.1)
222	(cairo:line-to cr 0.9 0.9)
223	(cairo:rel-line-to cr -0.4 0.0)
224	(cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
225	(cairo:stroke cr)))
226
227
228	(defun fill-and-stroke-common (cr)
229	(cairo:move-to cr 0.5 0.1)
230	(cairo:line-to cr 0.9 0.9)
231	(cairo:rel-line-to cr -0.4 0.0)
232	(cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
233	(cairo:close-path cr))
234
235
236	(define-snippet fill-and-stroke2 (cr)
237	(fill-and-stroke-common cr)
238	(cairo:move-to cr 0.25 0.1)
239	(cairo:rel-line-to cr 0.2 0.2)
240	(cairo:rel-line-to cr -0.2 0.2)
241	(cairo:rel-line-to cr -0.2 -0.2)
242	(cairo:close-path cr)
243
244	(cairo:set-source-color cr 0 0 1)
245	(cairo:fill cr t)
246	(cairo:set-source-color cr 0 0 0)
247	(cairo:stroke cr))
248
249
250	(define-snippet fill-and-stroke (cr)
251	(fill-and-stroke-common cr)
252
253	(cairo:set-source-color cr 0 0 1)
254	(cairo:fill cr t)
255	(cairo:set-source-color cr 0 0 0)
256	(cairo:stroke cr))
257
258
259	(define-snippet gradient (cr)
260	(let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0)))
261	(cairo:pattern-add-color-stop pattern 1 0 0 0 1)
262	(cairo:pattern-add-color-stop pattern 0 1 1 1 1)
263	(cairo:rectangle cr 0 0 1 1)
264	(setf (cairo:source cr) pattern)
265	(cairo:fill cr))
266	(let ((pattern (cairo:pattern-create-radial 0.45 0.4 0.1 0.4 0.4 0.5)))
267	(cairo:pattern-add-color-stop pattern 0 1 1 1 1)
268	(cairo:pattern-add-color-stop pattern 1 0 0 0 1)
269	(setf (cairo:source cr) pattern)
270	(cairo:circle cr 0.5 0.5 0.3)
271	(cairo:fill cr)))
272
273
274	(define-snippet image (cr)
275	(let ((image (cairo:image-surface-create-from-png
276	#p"clg:examples;romedalen.png")))
277	(cairo:translate cr 0.5 0.5)
278	(cairo:rotate cr (deg-to-rad 45))
279	(let ((width (cairo:surface-width image))
280	(height (cairo:surface-height image)))
281	(cairo:scale cr (/ 1.0 width) (/ 1.0 height))
282	(cairo:translate cr (* -0.5 width) (* -0.5 height)))
283	(cairo:set-source-surface cr image 0 0)
284	(cairo:paint cr)))
285
286
287	(define-snippet image-pattern (cr)
288	(let* ((image (cairo:image-surface-create-from-png
289	#p"clg:examples;romedalen.png"))
290	(pattern (cairo:pattern-create-for-surface image)))
291	(setf (cairo:pattern-extend pattern) :repeat)
292	(cairo:translate cr 0.5 0.5)
293	(cairo:rotate cr (deg-to-rad 45))
294	(cairo:scale cr (/ 1.0 (sqrt 2)) (/ 1.0 (sqrt 2)))
295	(cairo:translate cr -0.5 -0.5)
296	(let ((width (cairo:surface-width image))
297	(height (cairo:surface-height image))
298	(matrix (make-instance 'cairo:matrix)))
299	(cairo:matrix-init-scale matrix (* 5 width) (* 5 height))
300	(setf (cairo:pattern-matrix pattern) matrix))
301	(setf (cairo:source cr) pattern)
302	(cairo:rectangle cr 0.0 0.0 1.0 1.0)
303	(cairo:fill cr)))
304
305
306	;; (defun snippet-set-bg-svg (cr filename)
307	;; (let ((handle (make-instance 'rsvg:handle :filename filename)))
308	;; (cairo:with-context (cr)
309	;; (with-slots (rsvg:width rsvg:height) (rsvg:handle-dimensions handle)
310	;; (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height))
311	;; (rsvg:cairo-render cr handle)))))
312
313	;; (define-snippet librsvg (cr)
314	;; (snippet-set-bg-svg cr "clg:examples;home.svg"))
315
316
317	(defmacro define-operator-snippet (operator)
318	(let ((name (intern (format nil "OPERATOR-~A" operator))))
319	`(define-snippet ,name (cr)
320	(snippet-set-bg-svg cr "clg:examples;freedesktop.svg")
321	(setf (cairo:operator cr) ,operator)
322
323	(cairo:set-source-color cr 1.0 0.0 0.0 0.5)
324	(cairo:rectangle cr 0.2 0.2 0.5 0.5)
325	(cairo:fill)
326
327	(cairo:set-source-color cr 0.0 1.0 0.0)
328	(cairo:rectangle cr 0.4 0.4 0.4 0.4)
329	(cairo:fill)
330
331	(cairo:set-source-color cr 0.0 0.0 1.0)
332	(cairo:rectangle cr 0.6 0.6 0.3 0.3)
333	(cairo:fill))))
334
335	;; (define-operator-snippet :add)
336	;; (define-operator-snippet :atop)
337	;; (define-operator-snippet :atop-reverse)
338	;; (define-operator-snippet :in)
339	;; (define-operator-snippet :in-reverse)
340	;; (define-operator-snippet :out)
341	;; (define-operator-snippet :out-reverse)
342	;; (define-operator-snippet :over)
343	;; (define-operator-snippet :over-reverse)
344	;; (define-operator-snippet :saturate)
345	;; (define-operator-snippet :xor)
346
347
348
349	(define-snippet path (cr)
350	(cairo:move-to cr 0.5 0.1)
351	(cairo:line-to cr 0.9 0.9)
352	(cairo:rel-line-to cr -0.4 0.0)
353	(cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
354	(cairo:stroke cr))
355
356
357	;; (let ((path))
358	;; (define-snippet pattern-fill (cr)
359	;; (let ((spikes 10)
360	;; (text "KAPOW!"))
361	;; (unless path
362	;; (let ((x-fuzz 0.08)
363	;; (y-fuzz 0.08)
364	;; (x-inner-radius 0.3)
365	;; (y-inner-radius 0.2)
366	;; (x-outer-radius 0.45)
367	;; (y-outer-radius 0.35))
368	;; (setq path (make-array (* 2 spikes)))
369	;; (loop
370	;; for i from 0 below (* 2 spikes)
371	;; do (multiple-value-bind (x-radius y-radius)
372	;; (if (evenp i)
373	;; (values x-inner-radius y-inner-radius)
374	;; (values x-outer-radius y-outer-radius))
375	;; (setf
376	;; (svref path i)
377	;; (cons
378	;; (+ 0.5 (* (cos (* pi (/ i spikes))) x-radius)
379	;; (* (random 1.0) x-fuzz))
380	;; (+ 0.5 (* (sin (* pi (/ i spikes))) y-radius)
381	;; (* (random 1.0) y-fuzz))))))))
382
383	;; (setf (cairo:line-width cr) 0.01)
384	;; (cairo:move-to cr (car (svref path 0)) (cdr (svref path 0)))
385	;; (loop
386	;; for i from 1 below (* 2 spikes)
387	;; do (cairo:line-to cr (car (svref path i)) (cdr (svref path i))))
388	;; (cairo:close-path cr)
389	;; (cairo:stroke cr)
390	;; (cairo:move-to cr
391	;; (car (svref path (1- spikes))) (cdr (svref path (1- spikes))))
392
393	;; (cairo:select-font-face cr "Sans" :normal :bold)
394	;; (time (cairo:text-path cr text))
395	;; (cairo:set-source-color cr 1.0 1.0 0.5)
396	;; (cairo:fill cr)
397
398	;; (cairo:set-font-size cr 0.2)
399	;; (let* ((extents (cairo:text-extents cr text))
400	;; (x (- 0.5 (+ (* 0.5 (cairo:text-extents-width extents)) (cairo:text-extents-x-bearing extents))))
401	;; (y (- 0.5 (+ (* 0.5 (cairo:text-extents-height extents)) (cairo:text-extents-y-bearing extents)))))
402
403	;; (cairo:move-to cr x y)
404	;; (cairo:text-path cr text)
405	;; (cairo:set-source-color cr 0 0 0)
406	;; (cairo:stroke cr)))))
407
408
409
410	(define-snippet set-line-cap (cr)
411	(setf (cairo:line-width cr) 0.12)
412	(setf (cairo:line-cap cr) :butt)
413	(cairo:move-to cr 0.25 0.2)
414	(cairo:line-to cr 0.25 0.8)
415	(cairo:stroke cr)
416	(setf (cairo:line-cap cr) :round)
417	(cairo:move-to cr 0.5 0.2)
418	(cairo:line-to cr 0.5 0.8)
419	(cairo:stroke cr)
420	(setf (cairo:line-cap cr) :square)
421	(cairo:move-to cr 0.75 0.2)
422	(cairo:line-to cr 0.75 0.8)
423	(cairo:stroke cr)
424
425	;; draw helping lines
426	(cairo:set-source-color cr 1 0.2 0.2)
427	(setf (cairo:line-width cr) 0.01)
428	(cairo:move-to cr 0.25 0.2)
429	(cairo:line-to cr 0.25 0.8)
430	(cairo:move-to cr 0.5 0.2)
431	(cairo:line-to cr 0.5 0.8)
432	(cairo:move-to cr 0.75 0.2)
433	(cairo:line-to cr 0.75 0.8)
434	(cairo:stroke cr))
435
436
437	(define-snippet set-line-join (cr)
438	(setf (cairo:line-width cr) 0.16)
439	(cairo:move-to cr 0.3 0.33)
440	(cairo:rel-line-to cr 0.2 -0.2)
441	(cairo:rel-line-to cr 0.2 0.2)
442	(setf (cairo:line-join cr) :miter) ; default
443	(cairo:stroke cr)
444
445	(cairo:move-to cr 0.3 0.63)
446	(cairo:rel-line-to cr 0.2 -0.2)
447	(cairo:rel-line-to cr 0.2 0.2)
448	(setf (cairo:line-join cr) :bevel)
449	(cairo:stroke cr)
450
451	(cairo:move-to cr 0.3 0.93)
452	(cairo:rel-line-to cr 0.2 -0.2)
453	(cairo:rel-line-to cr 0.2 0.2)
454	(setf (cairo:line-join cr) :round)
455	(cairo:stroke cr))
456
457
458
459	(define-snippet text (cr)
460	(cairo:select-font-face cr "Sans" :normal :bold)
461	;; ;(setf (cairo:font-size cr) 0.35)
462	(cairo:set-font-size cr 0.35)
463
464	(cairo:move-to cr 0.04 0.53)
465	(cairo:show-text cr "Hello")
466
467	(cairo:move-to cr 0.27 0.65)
468	(cairo:text-path cr "void")
469	(cairo:set-source-color cr 0.5 0.5 1)
470	(cairo:fill cr t)
471
472	(cairo:set-source-color cr 0 0 0)
473	(setf (cairo:line-width cr) 0.01)
474	(cairo:stroke cr)
475
476	;; draw helping lines
477	(cairo:set-source-color cr 1 0.2 0.2 0.6)
478	(cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360))
479	(cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360))
480	(cairo:fill cr))
481
482
483	(define-snippet text-align-center (cr)
484	(let ((text "cairo"))
485	(cairo:select-font-face cr "Sans" :normal :normal)
486	(cairo:set-font-size cr 0.2)
487
488	(let* ((extents (cairo:text-extents cr text))
489	(x (- 0.5 (+ (/ (cairo:text-extents-width extents) 2) (cairo:text-extents-x-bearing extents))))
490	(y (- 0.5 (+ (/ (cairo:text-extents-height extents) 2) (cairo:text-extents-y-bearing extents)))))
491	(cairo:move-to cr x y)
492	(cairo:show-text cr text)
493
494	;; draw helping lines
495	(cairo:set-source-color cr 1.0 0.2 0.2 0.6)
496	(cairo:circle cr x y 0.05)
497	(cairo:fill cr)
498	(cairo:move-to cr 0.5 0.0)
499	(cairo:rel-line-to cr 0.0 1.0)
500	(cairo:move-to cr 0.0 0.5)
501	(cairo:rel-line-to cr 1.0 0.0)
502	(cairo:stroke cr))))
503
504	(define-snippet text-extents (cr)
505	(let ((text "cairo"))
506	(cairo:select-font-face cr "Sans" :normal :normal)
507	(cairo:set-font-size cr 0.4)
508
509	(let* ((extents (cairo:text-extents cr text))
510	(x 0.1)
511	(y 0.6))
512	(cairo:move-to cr x y)
513	(cairo:show-text cr text)
514
515	;; draw helping lines
516	(cairo:set-source-color cr 1.0 0.2 0.2 0.6)
517	(cairo:circle cr x y 0.05)
518	(cairo:fill cr)
519	(cairo:move-to cr x y)
520	(cairo:rel-line-to cr 0 (- (cairo:text-extents-height extents)))
521	(cairo:rel-line-to cr (cairo:text-extents-width extents) 0)
522	(cairo:rel-line-to cr
523	(cairo:text-extents-x-bearing extents)
524	(- (cairo:text-extents-y-bearing extents)))
525	(cairo:stroke cr))))
526
527
528	(defun create-tests ()
529	;; (rc-parse "clg:examples;testgtkrc2")
530	;; (rc-parse "clg:examples;testgtkrc")
531
532	(let* ((main-window (make-instance 'window
533	:title "testcairo.lisp" :name "main-window"
534	:default-width 200 :default-height 400
535	:allow-grow t :allow-shrink nil))
536	(scrolled-window (make-instance 'scrolled-window
537	:hscrollbar-policy :automatic
538	:vscrollbar-policy :automatic
539	:border-width 10))
540	(close-button (make-instance 'button
541	:label "close" :can-default t
542	:signal (list 'clicked #'widget-destroy
543	:object main-window))))
544
545	(let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
546	(setf
547	(window-icon main-window)
548	(gdk:pixbuf-add-alpha icon t 254 254 252)))
549
550	;; Main box
551	(make-instance 'v-box
552	:parent main-window
553	:child-args '(:expand nil)
554	:child (list (make-instance 'label :label (gtk-version)) :fill nil)
555	:child (list (make-instance 'label :label (clg-version)) :fill nil)
556	:child (list (make-instance 'label
557	:label #-cmu(format nil "~A (~A)"
558	(lisp-implementation-type)
559	(lisp-implementation-version))
560	;; The version string in CMUCL is far too long
561	#+cmu(lisp-implementation-type))
562	:fill nil)
563	:child (list scrolled-window :expand t)
564	:child (make-instance 'h-separator)
565	:child (make-instance 'v-box
566	:homogeneous nil :spacing 10 :border-width 10
567	:child close-button))
568
569	(let ((content-box
570	(make-instance 'v-box
571	:focus-vadjustment (scrolled-window-vadjustment scrolled-window)
572	:children (mapcar #'(lambda (snippet)
573	(create-button (string-downcase snippet) snippet))
574	(sort snippets #'string<)))))
575	(scrolled-window-add-with-viewport scrolled-window content-box))
576
577	(widget-grab-focus close-button)
578	(widget-show-all main-window)
579	main-window))
580
581
582	(clg-init)
583	;;(rsvg:init)