X-Git-Url: http://uxul.de/gitweb/?p=uxul-world.git;a=blobdiff_plain;f=bmp.lisp;fp=bmp.lisp;h=d6c547143126fdbbb7d5b11058e2d9a5aeefd4ce;hp=3597045e2dfced9005f6df234a6d27eeb91ed4a2;hb=f05e44b099e5976411b3ef1f980ec616bd221425;hpb=8f6d2e9fa2cee1be6687044f2f4813630305682b

diff --git a/bmp.lisp b/bmp.lisp
index 3597045..d6c5471 100755
--- a/bmp.lisp
+++ b/bmp.lisp
@@ -126,6 +126,18 @@ all."
 	  (setf (elt dst-blob (+ i dst-pos))
 		(elt src-blob (+ i src-pos))))))))
 
+(defun sub-image (x y width height source-blob source-width source-height)
+  (create-bmp-image
+   width height
+   (lambda (pixels)
+     (do ((cx 0 (1+ cx))) ((= cx width))
+       (do ((cy 0 (1+ cy))) ((= cy height))
+	 (let ((dst-pos (* 4 (+ cx (* cy width))))
+	       (src-pos (* 4 (+ cx x (* (+ cy y) source-width)))))
+	   (do ((i 0 (1+ i))) ((= i 4))
+	     (setf (elt pixels (+ i dst-pos))
+		   (elt source-blob (+ i src-pos))))))))))
+
 (defun resize-pixeldata
     (argb-pixeldata old-width old-height new-width new-height
      &optional (new-pixeldata (make-array (list (* 4 new-width new-height))