--- /dev/null
+(in-package :uxul-world)\r
+\r
+\r
+;; this should go into functions.lisp\r
+\r
+(defun intersection-interval (a b c d)\r
+ "We assume a<b and c<d. Compute the intersection-interval between\r
+[a;b] and [c;d]. Return three values: 1. generalized boolean whether\r
+they intersect. 2. lower bound, 3. upper bound"\r
+ (let\r
+ ((r-a (max a c)) (r-b (min b d)))\r
+ (values (< r-a r-b) r-a r-b)))\r
+\r
+(defun intersection-rectangle (x1 y1 x2 y2 x3 y3 x4 y4)\r
+ "Compute the intersection-rectangle between the rectangle with\r
+diagonal points (x1,y1) and (x2, y2) and the one with (x3,\r
+y3),(x4,y4)? Assuming x1<x2, x3<x4, y same. Return five values x a b\r
+c d, where x is a generalized boolean whether they overlap at all,\r
+(a b) is the upper left and (c d) is the lower right edge of the\r
+rectangle, or nil if they dont intersect."\r
+ (multiple-value-bind\r
+ (ov1 ix1 ix2) (intersection-interval x1 x2 x3 x4)\r
+ (multiple-value-bind\r
+ (ov2 iy1 iy2) (intersection-interval y1 y2 y3 y4)\r
+ (values (and ov1 ov2) ix1 iy1 ix2 iy2))))\r
+\r
+(defun overlapping-area (x1 y1 x2 y2 x3 y3 x4 y4)\r
+ "Compute the overlapping-area between the rectangle with diagonal\r
+points (x1,y1) and (x2, y2) and the one with (x3, y3),(x4,y4)?\r
+Assuming x1<x2, x3<x4, y same. Return 0 if they dont intersect at\r
+all."\r
+ (multiple-value-bind\r
+ (ov ix1 iy1 ix2 iy2)\r
+ (intersection-rectangle x1 y1 x2 y2 x3 y3 x4 y4)\r
+ (cond\r
+ (ov (* (- ix2 ix1) (- iy2 iy1))) (t 0))))\r
+\r
+;; only supports 32 bit images\r
+\r
+(defun load-file-to-sequence (file)\r
+ (with-open-file (in file :element-type '(unsigned-byte 8)) \r
+ (let* ((length (file-length in))\r
+ (content (make-array (list length)\r
+ :element-type '(unsigned-byte 8)\r
+ :adjustable nil)))\r
+ (read-sequence content in) content)))\r
+\r
+(defun write-file-from-sequence (file sequence)\r
+ (with-open-file (out file :element-type '(unsigned-byte 8)\r
+ :direction :output)\r
+ (write-sequence sequence out)))\r
+\r
+(defun word-at (sequence elt)\r
+ (+ (ash (elt sequence (1+ elt)) 8) (elt sequence elt)))\r
+\r
+(defun set-word-at (sequence elt num)\r
+ (setf (elt sequence elt) (mod num 256))\r
+ (setf (elt sequence (1+ elt)) (mod (ash num -8) 256)))\r
+\r
+(defun dword-at (sequence elt)\r
+ (+\r
+ (ash (elt sequence (+ 3 elt)) 24)\r
+ (ash (elt sequence (+ 2 elt)) 16)\r
+ (ash (elt sequence (+ 1 elt)) 8)\r
+ (elt sequence elt)))\r
+\r
+(defun set-dword-at (sequence elt num)\r
+ (setf (elt sequence elt) (mod num 256))\r
+ (setf (elt sequence (+ 1 elt)) (mod (ash num -8) 256))\r
+ (setf (elt sequence (+ 2 elt)) (mod (ash num -16) 256))\r
+ (setf (elt sequence (+ 3 elt)) (mod (ash num -24) 256)))\r
+\r
+(defun signed-dword-at (sequence elt)\r
+ (let ((r (dword-at sequence elt)))\r
+ (if (> r (expt 2 31))\r
+ (- r (expt 2 32))\r
+ r)))\r
+\r
+(defun set-signed-dword-at (sequence elt num)\r
+ (set-dword-at sequence elt\r
+ (if (> num 0) num\r
+ (+ num (expt 2 32)))))\r
+\r
+(defun verify-bmp-magic-bytes (sequence)\r
+ (= (word-at sequence 0) 19778))\r
+\r
+(defun bmp-size-in-header (sequence)\r
+ (dword-at sequence 2))\r
+\r
+(defun bmp-image-data-offset (sequence)\r
+ (dword-at sequence 10))\r
+\r
+(defun bmp-bi-compression (sequence)\r
+ (dword-at sequence 30))\r
+\r
+(defun bmp-width (sequence)\r
+ (signed-dword-at sequence 18))\r
+\r
+(defun bmp-signed-height (sequence)\r
+ (signed-dword-at sequence 22))\r
+\r
+(defun bmp-height (sequence)\r
+ (abs (bmp-signed-height sequence)))\r
+\r
+(defun bmp-pixel-data (sequence &key (destructive nil))\r
+ (let* ((w (bmp-width sequence))\r
+ (h (bmp-height sequence))\r
+ (o (bmp-image-data-offset sequence))\r
+ (l (* w h 4)))\r
+ (if destructive\r
+ (make-array (list l)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to sequence\r
+ :displaced-index-offset o)\r
+ (subseq sequence o (+ o l)))))\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
+ :element-type '(unsigned-byte 8)\r
+ :adjustable nil)))\r
+ (let*\r
+ ((ccolor (make-array '(4)\r
+ :adjustable nil\r
+ :element-type 'rational))\r
+ (times-x (/ old-width new-width))\r
+ (times-y (/ old-height new-height)))\r
+ (labels ((pixel-at (x y)\r
+ (let ((fpos (* 4 (+ x (* y old-width)))))\r
+ (make-array '(4)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to argb-pixeldata\r
+ :displaced-index-offset fpos)))\r
+ (new-pixel-at (x y)\r
+ (let ((fpos (* 4 (+ x (* y new-width)))))\r
+ (make-array '(4)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to new-pixeldata\r
+ :displaced-index-offset fpos)))\r
+ (color-of-rect (x1 y1 x2 y2 color-out)\r
+ (let*\r
+ ((area (* (- x2 x1) (- y2 y1))))\r
+ (dotimes (i 4) (setf (elt ccolor i) 0))\r
+ (loop for cy from (floor y1) to (ceiling y2) do\r
+ (loop for cx from (floor x1) to (ceiling x2) do\r
+ (let\r
+ ((c-area\r
+ (overlapping-area\r
+ x1 y1 x2 y2 cx cy\r
+ (1+ cx) (1+ cy))))\r
+ (map-into ccolor\r
+ #'(lambda (x y) \r
+ (+ x (* c-area y)))\r
+ ccolor (pixel-at\r
+ (min cx (1- old-width))\r
+ (min cy (1- old-height)))))))\r
+ (map-into color-out\r
+ #'(lambda (x)\r
+ (round (/ x area))) ccolor)))\r
+ (interpol (x y color-out)\r
+ (color-of-rect (* times-x x)\r
+ (* times-y y)\r
+ (* times-x (1+ x))\r
+ (* times-y (1+ y))\r
+ color-out)))\r
+ (do ((cy 0 (1+ cy))) ((= cy new-height))\r
+ (do ((cx 0 (1+ cx))) ((= cx new-width))\r
+ (let ((np (new-pixel-at cx cy)))\r
+ (interpol cx cy np))))\r
+ new-pixeldata)))\r
+\r
+(defun create-bmp-image (width height argb-data-get)\r
+ "argb-data-get is a function taking an array on which it saves the\r
+image-data (for efficiency-reasons)."\r
+ (let*\r
+ ((imagesize (* width height 4))\r
+ (filesize (+ imagesize 54 333))\r
+ (file-data (make-array (list filesize)\r
+ :element-type '(unsigned-byte 8)\r
+ :adjustable nil))\r
+ (image-data (make-array (list imagesize)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to file-data\r
+ :displaced-index-offset 54)))\r
+ ;; headings\r
+ (set-word-at file-data 0 19778) ; magic number\r
+ (set-dword-at file-data 2 filesize)\r
+ (set-dword-at file-data 6 0) ; reserved\r
+ (set-dword-at file-data 10 54) ; image-data-offset\r
+ (set-dword-at file-data 14 40) ; header size\r
+ (set-signed-dword-at file-data 18 width)\r
+ (set-signed-dword-at file-data 22 height)\r
+ (set-word-at file-data 26 1) ; not used here\r
+ (set-word-at file-data 28 32) ; bits per pixel\r
+ (set-dword-at file-data 30 0) ; image is in rgb-format\r
+ (set-dword-at file-data 34 imagesize) ; size of image-data\r
+ (set-signed-dword-at file-data 38 0) ; not used here\r
+ (set-signed-dword-at file-data 42 0) ; not used here\r
+ (set-dword-at file-data 46 0) ; no color table\r
+ (set-dword-at file-data 50 0) ; no color table\r
+ ;; data\r
+ (funcall argb-data-get image-data)\r
+ file-data))\r
+\r
+(defun resize-bmp-blob (seq width height)\r
+ (let*\r
+ ((w (bmp-width seq))\r
+ (h (bmp-height seq))\r
+ (img (bmp-pixel-data seq))\r
+ (res #'(lambda (seq) (resize-pixeldata img w h width height seq))))\r
+ (create-bmp-image width height res)))\r
+\r
+\r
+(defun resize-bmp-file (infile outfile width height)\r
+ (write-file-from-sequence\r
+ outfile\r
+ (resize-bmp-blob (load-file-to-sequence infile) width height)))\r
+\r
+\r
+(defun show-sdl-pixeldata (pixeldata width height)\r
+ (labels ((pixel-at (x y)\r
+ (let ((fpos (* 4 (+ x (* y width)))))\r
+ ;(subseq pixeldata fpos (+ 4 fpos))\r
+ (make-array '(4)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to pixeldata\r
+ :displaced-index-offset fpos))))\r
+ (sdl:with-init ()\r
+ (sdl:window width height)\r
+ (do ((cy 0 (1+ cy))) ((= cy height))\r
+ (do ((cx 0 (1+ cx))) ((= cx width))\r
+ (let ((cpix (pixel-at cx cy)))\r
+ (sdl:draw-pixel-* (1+ cx) (1+ cy)\r
+ :color (sdl:color\r
+ :r (elt cpix 2)\r
+ :g (elt cpix 1)\r
+ :b (elt cpix 0))))))\r
+ (sdl:update-display)\r
+ (sdl:with-events ()\r
+ (:idle t)\r
+ (:quit-event () t)))))\r
+\r
+(defun show-sdl (filename)\r
+ (let* ((seq (load-file-to-sequence filename))\r
+ (w (bmp-width seq))\r
+ (h (bmp-height seq))\r
+ (img (bmp-pixel-data seq)))\r
+ (show-sdl-pixeldata img w h)))\r
+\r
+(defun show-sdl-resized (filename width height)\r
+ (let*\r
+ ((seq (load-file-to-sequence filename))\r
+ (w (bmp-width seq))\r
+ (h (bmp-height seq))\r
+ (img (bmp-pixel-data seq))\r
+ (res (resize-pixeldata img w h width height)))\r
+ (show-sdl-pixeldata res width height)))\r
+\r
+(defun as-alpha-value (f b a)\r
+ (coerce\r
+ (round (/ (+ (* f a) (* b (- 255 a))) 255))\r
+ '(unsigned-byte 8)))\r
+\r
+(defun bmp-to-ppm (inblob background-rgb)\r
+ (let*\r
+ ((seq inblob)\r
+ (width (bmp-width seq))\r
+ (height (bmp-height seq))\r
+ (img (bmp-pixel-data seq)))\r
+ (with-output-to-string (out)\r
+ (format out "P3~%")\r
+ (format out "~d ~d~%255~%" width height)\r
+ (labels ((pixel-at (x y)\r
+ (let ((fpos (* 4 (+ x (* y width)))))\r
+ (make-array '(4)\r
+ :element-type '(unsigned-byte 8)\r
+ :displaced-to img\r
+ :displaced-index-offset fpos))))\r
+ (do ((cy 0 (1+ cy))) ((= cy height))\r
+ (do ((cx 0 (1+ cx))) ((= cx width))\r
+ (let* ((cpix (pixel-at cx cy))\r
+ (alpha (elt cpix 3))\r
+ (r (as-alpha-value\r
+ (elt cpix 2) (elt background-rgb 2) alpha))\r
+ (g (as-alpha-value\r
+ (elt cpix 1) (elt background-rgb 1) alpha))\r
+ (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
projects / uxul-world.git / blobdiff