;;; -*- lisp -*-\r
\r
-;;; Copyright 2010 Christoph Senjak\r
+;;; Copyright 2010-2011 Christoph Senjak\r
\r
(in-package :uxul-world)\r
\r
: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