X-Git-Url: http://uxul.de/gitweb/?a=blobdiff_plain;f=bmp.lisp;h=d6c547143126fdbbb7d5b11058e2d9a5aeefd4ce;hb=refs%2Fremotes%2Forigin%2FHEAD;hp=51faca9cd48aae07d9b4a3caaa951472b51255cc;hpb=3513580fa41deb8023977f77e64997708ff26455;p=uxul-world.git

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