Works again.

[uxul-world.git] / bmp.lisp

diff --git a/bmp.lisp b/bmp.lisp
index 51faca9..d6c5471 100755 (executable)
--- a/bmp.lisp
+++ b/bmp.lisp
@@ -1,7 +1,8 @@
-(in-package :uxul-world)\r
+;;; -*- lisp -*-\r
 \r
+;;; Copyright 2010-2011 Christoph Senjak\r
 \r
-;; this should go into functions.lisp\r
+(in-package :uxul-world)\r
 \r
 (defun intersection-interval (a b c d)\r
   "We assume a<b and c<d. Compute the intersection-interval between\r
@@ -114,6 +115,29 @@ all."
                    :displaced-index-offset o)\r
        (subseq sequence o (+ o l)))))\r
 \r
+(defun blit-image (x y src-width src-height src-blob\r
+                  dst-width dst-height dst-blob)\r
+  (declare (ignore dst-height))\r
+  (do ((cx 0 (1+ cx))) ((= cx src-width))\r
+    (do ((cy 0 (1+ cy))) ((= cy src-height))\r
+      (let ((src-pos (* 4 (+ cx (* cy src-width))))\r
+           (dst-pos (* 4 (+ (+ x cx) (* (+ y cy) dst-width)))))\r
+       (do ((i 0 (1+ i))) ((= i 4))\r
+         (setf (elt dst-blob (+ i dst-pos))\r
+               (elt src-blob (+ i src-pos))))))))\r
+\r
+(defun sub-image (x y width height source-blob source-width source-height)\r
+  (create-bmp-image\r
+   width height\r
+   (lambda (pixels)\r
+     (do ((cx 0 (1+ cx))) ((= cx width))\r
+       (do ((cy 0 (1+ cy))) ((= cy height))\r
+        (let ((dst-pos (* 4 (+ cx (* cy width))))\r
+              (src-pos (* 4 (+ cx x (* (+ cy y) source-width)))))\r
+          (do ((i 0 (1+ i))) ((= i 4))\r
+            (setf (elt pixels (+ i dst-pos))\r
+                  (elt source-blob (+ i src-pos))))))))))\r
+\r
 (defun resize-pixeldata\r
     (argb-pixeldata old-width old-height new-width new-height\r
      &optional (new-pixeldata (make-array (list (* 4 new-width new-height))\r
@@ -287,4 +311,4 @@ image-data (for efficiency-reasons)."
                   (b (as-alpha-value\r
                       (elt cpix 0) (elt background-rgb 0) alpha))\r
                  )\r
-             (format out "~d ~d ~d~%" r g b))))))))
\ No newline at end of file
+             (format out "~d ~d ~d~%" r g b))))))))\r