bmp.lisp

   1 ;;; -*- lisp -*-\r
   2 \r
   3 ;;; Copyright 2010-2011 Christoph Senjak\r
   4 \r
   5 (in-package :uxul-world)\r
   6 \r
   7 (defun intersection-interval (a b c d)\r
   8   "We assume a<b and c<d. Compute the intersection-interval between\r
   9 [a;b] and [c;d]. Return three values: 1. generalized boolean whether\r
  10 they intersect. 2. lower bound, 3. upper bound"\r
  11   (let\r
  12       ((r-a (max a c)) (r-b (min b d)))\r
  13     (values (< r-a r-b) r-a r-b)))\r
  14 \r
  15 (defun intersection-rectangle (x1 y1 x2 y2 x3 y3 x4 y4)\r
  16   "Compute the intersection-rectangle between the rectangle with\r
  17 diagonal points (x1,y1) and (x2, y2) and the one with (x3,\r
  18 y3),(x4,y4)?  Assuming x1<x2, x3<x4, y same. Return five values x a b\r
  19 c d, where x is a generalized boolean whether they overlap at all,\r
  20 (a b) is the upper left and (c d) is the lower right edge of the\r
  21 rectangle, or nil if they dont intersect."\r
  22   (multiple-value-bind\r
  23         (ov1 ix1 ix2) (intersection-interval x1 x2 x3 x4)\r
  24     (multiple-value-bind\r
  25           (ov2 iy1 iy2) (intersection-interval y1 y2 y3 y4)\r
  26        (values (and ov1 ov2) ix1 iy1 ix2 iy2))))\r
  27 \r
  28 (defun overlapping-area (x1 y1 x2 y2 x3 y3 x4 y4)\r
  29   "Compute the overlapping-area between the rectangle with diagonal\r
  30 points (x1,y1) and (x2, y2) and the one with (x3, y3),(x4,y4)?\r
  31 Assuming x1<x2, x3<x4, y same. Return 0 if they dont intersect at\r
  32 all."\r
  33   (multiple-value-bind\r
  34         (ov ix1 iy1 ix2 iy2)\r
  35       (intersection-rectangle x1 y1 x2 y2 x3 y3 x4 y4)\r
  36     (cond\r
  37       (ov (* (- ix2 ix1) (- iy2 iy1))) (t 0))))\r
  38 \r
  39 ;; only supports 32 bit images\r
  40 \r
  41 (defun load-file-to-sequence (file)\r
  42   (with-open-file (in file :element-type '(unsigned-byte 8)) \r
  43          (let* ((length (file-length in))\r
  44                 (content (make-array (list length)\r
  45                                      :element-type '(unsigned-byte 8)\r
  46                                      :adjustable nil)))\r
  47            (read-sequence content in) content)))\r
  48 \r
  49 (defun write-file-from-sequence (file sequence)\r
  50   (with-open-file (out file :element-type '(unsigned-byte 8)\r
  51                        :direction :output)\r
  52     (write-sequence sequence out)))\r
  53 \r
  54 (defun word-at (sequence elt)\r
  55   (+ (ash (elt sequence (1+ elt)) 8) (elt sequence elt)))\r
  56 \r
  57 (defun set-word-at (sequence elt num)\r
  58   (setf (elt sequence elt) (mod num 256))\r
  59   (setf (elt sequence (1+ elt)) (mod (ash num -8) 256)))\r
  60 \r
  61 (defun dword-at (sequence elt)\r
  62   (+\r
  63    (ash (elt sequence (+ 3 elt)) 24)\r
  64    (ash (elt sequence (+ 2 elt)) 16)\r
  65    (ash (elt sequence (+ 1 elt)) 8)\r
  66    (elt sequence elt)))\r
  67 \r
  68 (defun set-dword-at (sequence elt num)\r
  69   (setf (elt sequence elt) (mod num 256))\r
  70   (setf (elt sequence (+ 1 elt)) (mod (ash num -8) 256))\r
  71   (setf (elt sequence (+ 2 elt)) (mod (ash num -16) 256))\r
  72   (setf (elt sequence (+ 3 elt)) (mod (ash num -24) 256)))\r
  73 \r
  74 (defun signed-dword-at (sequence elt)\r
  75   (let ((r (dword-at sequence elt)))\r
  76     (if (> r (expt 2 31))\r
  77         (- r (expt 2 32))\r
  78         r)))\r
  79 \r
  80 (defun set-signed-dword-at (sequence elt num)\r
  81   (set-dword-at sequence elt\r
  82                 (if (> num 0) num\r
  83                     (+ num (expt 2 32)))))\r
  84 \r
  85 (defun verify-bmp-magic-bytes (sequence)\r
  86   (= (word-at sequence 0) 19778))\r
  87 \r
  88 (defun bmp-size-in-header (sequence)\r
  89   (dword-at sequence 2))\r
  90 \r
  91 (defun bmp-image-data-offset (sequence)\r
  92   (dword-at sequence 10))\r
  93 \r
  94 (defun bmp-bi-compression (sequence)\r
  95   (dword-at sequence 30))\r
  96 \r
  97 (defun bmp-width (sequence)\r
  98   (signed-dword-at sequence 18))\r
  99 \r
 100 (defun bmp-signed-height (sequence)\r
 101   (signed-dword-at sequence 22))\r
 102 \r
 103 (defun bmp-height (sequence)\r
 104   (abs (bmp-signed-height sequence)))\r
 105 \r
 106 (defun bmp-pixel-data (sequence &key (destructive nil))\r
 107   (let* ((w (bmp-width sequence))\r
 108          (h (bmp-height sequence))\r
 109          (o (bmp-image-data-offset sequence))\r
 110          (l (* w h 4)))\r
 111     (if destructive\r
 112         (make-array (list l)\r
 113                     :element-type '(unsigned-byte 8)\r
 114                     :displaced-to sequence\r
 115                     :displaced-index-offset o)\r
 116         (subseq sequence o (+ o l)))))\r
 117 \r
 118 (defun blit-image (x y src-width src-height src-blob\r
 119                    dst-width dst-height dst-blob)\r
 120   (declare (ignore dst-height))\r
 121   (do ((cx 0 (1+ cx))) ((= cx src-width))\r
 122     (do ((cy 0 (1+ cy))) ((= cy src-height))\r
 123       (let ((src-pos (* 4 (+ cx (* cy src-width))))\r
 124             (dst-pos (* 4 (+ (+ x cx) (* (+ y cy) dst-width)))))\r
 125         (do ((i 0 (1+ i))) ((= i 4))\r
 126           (setf (elt dst-blob (+ i dst-pos))\r
 127                 (elt src-blob (+ i src-pos))))))))\r
 128 \r
 129 (defun sub-image (x y width height source-blob source-width source-height)\r
 130   (create-bmp-image\r
 131    width height\r
 132    (lambda (pixels)\r
 133      (do ((cx 0 (1+ cx))) ((= cx width))\r
 134        (do ((cy 0 (1+ cy))) ((= cy height))\r
 135          (let ((dst-pos (* 4 (+ cx (* cy width))))\r
 136                (src-pos (* 4 (+ cx x (* (+ cy y) source-width)))))\r
 137            (do ((i 0 (1+ i))) ((= i 4))\r
 138              (setf (elt pixels (+ i dst-pos))\r
 139                    (elt source-blob (+ i src-pos))))))))))\r
 140 \r
 141 (defun resize-pixeldata\r
 142     (argb-pixeldata old-width old-height new-width new-height\r
 143      &optional (new-pixeldata (make-array (list (* 4 new-width new-height))\r
 144                                           :element-type '(unsigned-byte 8)\r
 145                                           :adjustable nil)))\r
 146   (let*\r
 147       ((ccolor (make-array '(4)\r
 148                            :adjustable nil\r
 149                            :element-type 'rational))\r
 150        (times-x (/ old-width new-width))\r
 151        (times-y (/ old-height new-height)))\r
 152     (labels ((pixel-at (x y)\r
 153                (let ((fpos (* 4 (+ x (* y old-width)))))\r
 154                  (make-array '(4)\r
 155                              :element-type '(unsigned-byte 8)\r
 156                              :displaced-to argb-pixeldata\r
 157                              :displaced-index-offset fpos)))\r
 158              (new-pixel-at (x y)\r
 159                (let ((fpos (* 4 (+ x (* y new-width)))))\r
 160                  (make-array '(4)\r
 161                              :element-type '(unsigned-byte 8)\r
 162                              :displaced-to new-pixeldata\r
 163                              :displaced-index-offset fpos)))\r
 164              (color-of-rect (x1 y1 x2 y2 color-out)\r
 165                (let*\r
 166                    ((area (* (- x2 x1) (- y2 y1))))\r
 167                  (dotimes (i 4) (setf (elt ccolor i) 0))\r
 168                  (loop for cy from (floor y1) to (ceiling y2) do\r
 169                       (loop for cx from (floor x1) to (ceiling x2) do\r
 170                            (let\r
 171                                ((c-area\r
 172                                  (overlapping-area\r
 173                                   x1 y1 x2 y2 cx cy\r
 174                                   (1+ cx) (1+ cy))))\r
 175                              (map-into ccolor\r
 176                                        #'(lambda (x y) \r
 177                                            (+ x (* c-area y)))\r
 178                                        ccolor (pixel-at\r
 179                                                (min cx (1- old-width))\r
 180                                                (min cy (1- old-height)))))))\r
 181                  (map-into color-out\r
 182                            #'(lambda (x)\r
 183                                (round (/ x area))) ccolor)))\r
 184              (interpol (x y color-out)\r
 185                (color-of-rect (* times-x x)\r
 186                               (* times-y y)\r
 187                               (* times-x (1+ x))\r
 188                               (* times-y (1+ y))\r
 189                               color-out)))\r
 190       (do ((cy 0 (1+ cy))) ((= cy new-height))\r
 191         (do ((cx 0 (1+ cx))) ((= cx new-width))\r
 192           (let ((np (new-pixel-at cx cy)))\r
 193                 (interpol cx cy np))))\r
 194       new-pixeldata)))\r
 195 \r
 196 (defun create-bmp-image (width height argb-data-get)\r
 197   "argb-data-get is a function taking an array on which it saves the\r
 198 image-data (for efficiency-reasons)."\r
 199   (let*\r
 200       ((imagesize (* width height 4))\r
 201        (filesize (+ imagesize 54 333))\r
 202        (file-data (make-array (list filesize)\r
 203                               :element-type '(unsigned-byte 8)\r
 204                               :adjustable nil))\r
 205        (image-data (make-array (list imagesize)\r
 206                                :element-type '(unsigned-byte 8)\r
 207                                :displaced-to file-data\r
 208                                :displaced-index-offset 54)))\r
 209     ;; headings\r
 210     (set-word-at file-data 0 19778) ; magic number\r
 211     (set-dword-at file-data 2 filesize)\r
 212     (set-dword-at file-data 6 0) ; reserved\r
 213     (set-dword-at file-data 10 54) ; image-data-offset\r
 214     (set-dword-at file-data 14 40) ; header size\r
 215     (set-signed-dword-at file-data 18 width)\r
 216     (set-signed-dword-at file-data 22 height)\r
 217     (set-word-at file-data 26 1) ; not used here\r
 218     (set-word-at file-data 28 32) ; bits per pixel\r
 219     (set-dword-at file-data 30 0) ; image is in rgb-format\r
 220     (set-dword-at file-data 34 imagesize) ; size of image-data\r
 221     (set-signed-dword-at file-data 38 0) ; not used here\r
 222     (set-signed-dword-at file-data 42 0) ; not used here\r
 223     (set-dword-at file-data 46 0) ; no color table\r
 224     (set-dword-at file-data 50 0) ; no color table\r
 225     ;; data\r
 226     (funcall argb-data-get image-data)\r
 227     file-data))\r
 228 \r
 229 (defun resize-bmp-blob (seq width height)\r
 230     (let*\r
 231       ((w (bmp-width seq))\r
 232        (h (bmp-height seq))\r
 233        (img (bmp-pixel-data seq))\r
 234        (res #'(lambda (seq) (resize-pixeldata img w h width height seq))))\r
 235       (create-bmp-image width height res)))\r
 236 \r
 237 \r
 238 (defun resize-bmp-file (infile outfile width height)\r
 239   (write-file-from-sequence\r
 240    outfile\r
 241    (resize-bmp-blob (load-file-to-sequence infile) width height)))\r
 242 \r
 243 \r
 244 (defun show-sdl-pixeldata (pixeldata width height)\r
 245   (labels ((pixel-at (x y)\r
 246                     (let ((fpos (* 4 (+ x (* y width)))))\r
 247                       ;(subseq pixeldata fpos (+ 4 fpos))\r
 248                       (make-array '(4)\r
 249                                   :element-type '(unsigned-byte 8)\r
 250                                   :displaced-to pixeldata\r
 251                                   :displaced-index-offset fpos))))\r
 252     (sdl:with-init ()\r
 253       (sdl:window width height)\r
 254       (do ((cy 0 (1+ cy))) ((= cy height))\r
 255         (do ((cx 0 (1+ cx))) ((= cx width))\r
 256           (let ((cpix (pixel-at cx cy)))\r
 257             (sdl:draw-pixel-* (1+ cx) (1+ cy)\r
 258                               :color (sdl:color\r
 259                                       :r (elt cpix 2)\r
 260                                       :g (elt cpix 1)\r
 261                                       :b (elt cpix 0))))))\r
 262       (sdl:update-display)\r
 263       (sdl:with-events ()\r
 264         (:idle  t)\r
 265         (:quit-event () t)))))\r
 266 \r
 267 (defun show-sdl (filename)\r
 268   (let* ((seq (load-file-to-sequence filename))\r
 269          (w (bmp-width seq))\r
 270          (h (bmp-height seq))\r
 271          (img (bmp-pixel-data seq)))\r
 272     (show-sdl-pixeldata img w h)))\r
 273 \r
 274 (defun show-sdl-resized (filename width height)\r
 275   (let*\r
 276       ((seq (load-file-to-sequence filename))\r
 277        (w (bmp-width seq))\r
 278        (h (bmp-height seq))\r
 279        (img (bmp-pixel-data seq))\r
 280        (res (resize-pixeldata img w h width height)))\r
 281     (show-sdl-pixeldata res width height)))\r
 282 \r
 283 (defun as-alpha-value (f b a)\r
 284   (coerce\r
 285    (round (/ (+ (* f a) (* b (- 255 a))) 255))\r
 286    '(unsigned-byte 8)))\r
 287 \r
 288 (defun bmp-to-ppm (inblob background-rgb)\r
 289   (let*\r
 290       ((seq inblob)\r
 291        (width (bmp-width seq))\r
 292        (height (bmp-height seq))\r
 293        (img (bmp-pixel-data seq)))\r
 294     (with-output-to-string (out)\r
 295       (format out "P3~%")\r
 296       (format out "~d ~d~%255~%" width height)\r
 297       (labels ((pixel-at (x y)\r
 298                  (let ((fpos (* 4 (+ x (* y width)))))\r
 299                    (make-array '(4)\r
 300                                :element-type '(unsigned-byte 8)\r
 301                                :displaced-to img\r
 302                                :displaced-index-offset fpos))))\r
 303         (do ((cy 0 (1+ cy))) ((= cy height))\r
 304           (do ((cx 0 (1+ cx))) ((= cx width))\r
 305             (let* ((cpix (pixel-at cx cy))\r
 306                    (alpha (elt cpix 3))\r
 307                    (r (as-alpha-value\r
 308                        (elt cpix 2) (elt background-rgb 2) alpha))\r
 309                    (g (as-alpha-value\r
 310                        (elt cpix 1) (elt background-rgb 1) alpha))\r
 311                    (b (as-alpha-value\r
 312                        (elt cpix 0) (elt background-rgb 0) alpha))\r
 313                   )\r
 314               (format out "~d ~d ~d~%" r g b))))))))\r