Commits

Christian Kellermann committed 84d8a73

Enable PNG files as backgrounds.

Give a filename string to either the new-doodle background parameter
or the clear-screen procedure to load an image as background.

Comments (0)

Files changed (2)

 
   (set! *c* (cairo-create *c-surface*))
 
+
+
   (sdl-wm-set-caption title "Pretty Pics Inc.")
+
   (current-background background)
-  (apply cairo-set-source-rgba `(,*c* ,@background))
+
+  (if (string? background)
+      (doto *c*
+        (cairo-set-source-surface
+         (cairo-image-surface-create-from-png background)
+         0 0)
+        )
+        (apply cairo-set-source-rgba `(,*c* ,@background)))
+
   (doto *c*
         (cairo-rectangle 0 0 width height)
         (cairo-fill)
         (cairo-stroke))
+
   (sdl-flip *s*))
 
 (define (clear-screen #!optional (color (current-background)))
-  (let ((width (cairo-image-surface-get-width *c-surface*))
-        (height (cairo-image-surface-get-height *c-surface*)))
-    (apply cairo-set-source-rgba `(,*c* ,@color))
-    (doto *c*
-          (cairo-rectangle 0 0 width height)
-          (cairo-fill)
-          (cairo-stroke))))
+(let ((width (cairo-image-surface-get-width *c-surface*))
+      (height (cairo-image-surface-get-height *c-surface*)))
+  (if (list? color)
+      (apply cairo-set-source-rgba `(,*c* ,@color))
+      (begin
+        (doto *c*
+              (cairo-set-source-rgba 0 0 0 1)
+              (cairo-rectangle 0 0 width height)
+              (cairo-fill)
+              (cairo-stroke)
+              (cairo-set-source-surface
+               (cairo-image-surface-create-from-png color)
+               0 0))))
+  (doto *c*
+        (cairo-rectangle 0 0 width height)
+        (cairo-fill)
+        (cairo-stroke))))
 
 (define (show!)
   (cairo-surface-flush *c-surface*)
 Initialises the internal state and createas a window with the given
 dimensions and title.
 
+The background parameter can either be a doodle RGBA color list or a
+string pointing to a PNG file.
+
 <procedure>(show!)</procedure>
 
 Causes a redraw of the window.
 
-<procedure>(clear-screen!)</procedure>
+<procedure>(clear-screen! #!optional (color (current-background)))</procedure>
 
-Fills the screen with the {{current-background}} color.
+Fills the screen with the {{current-background}} color. Color can
+also be given as a string representing a filename to a PNG image which
+will be loaded instead.
 
 <procedure>(rectangle x y width height color)</procedure>