Skip to content
Newer
Older
100644 109 lines (95 sloc) 3.61 KB
e9c522a @slyrus added imageops (only has transpose-image at the moment)
authored Feb 6, 2011
1 ;;; Copyright (c) 2011 Cyrus Harmon, All rights reserved.
2 ;;; See COPYRIGHT file for details.
3
4 (in-package :opticl)
5
0846f8d @slyrus added discrete-convolution (and blur, sharpen)
authored Mar 2, 2011
6 (defun sum (array)
7 (let ((acc 0))
8 (map-array (lambda (v) (incf acc v)) array)
9 acc))
10
11 (defun sum-range (array vendr vstartr vendc vstartc)
12 (let ((acc 0))
13 (loop for i from vstartr below vendr
14 do (loop for j from vstartc below vendc
15 do (incf acc (aref array i j))))
16 acc))
17
18 (defmacro make-constrain-fn (min max)
19 `(lambda (val)
20 (cond ((<= val ,min) ,min)
21 ((>= val ,max) ,max)
22 (t (round val)))))
23
2aa2c1c @slyrus cleanup: rearrange some code
authored Feb 20, 2011
24 (defun constrain (val min max)
25 (let ((val (if (< val min) min val)))
26 (if (> val max)
27 max
28 val)))
29
30 (defun pixel-in-bounds (img y x)
31 (with-image-bounds (ymax xmax)
32 img
33 (and (>= y 0) (< y ymax)
34 (>= x 0) (< x xmax))))
35
36 (defmacro when-pixel-in-bounds ((img y x) &body body)
37 (let ((ymax (gensym)) (xmax (gensym)))
38 `(let ((,ymax (1- (array-dimension ,img 0)))
39 (,xmax (1- (array-dimension ,img 1))))
40 (if (and (<= 0 ,y ,ymax)
41 (<= 0 ,x ,xmax))
42 ,@body))))
43
e9c522a @slyrus added imageops (only has transpose-image at the moment)
authored Feb 7, 2011
44 (defun transpose-image (img)
45 (with-image-bounds (ymax xmax channels)
46 img
47 (let ((zimg (make-array
48 (cons xmax (cons ymax (when channels (list channels))))
49 :element-type (array-element-type img))))
50 (loop for i below ymax
51 do (loop for j below xmax
52 do (setf (pixel zimg j i) (pixel img i j))))
53 zimg)))
54
4597199 @slyrus added gamma functions and copy-image
authored Feb 7, 2011
55 (defun copy-image (img)
56 (with-image-bounds (ymax xmax channels)
57 img
657e528 @slyrus added crop-image and exported crop-image and copy-image
authored Feb 20, 2011
58 (let ((new-image (make-array
3794024 @slyrus fix crop-image to use new size, not original size
authored Feb 20, 2011
59 (cons ymax (cons xmax (when channels (list channels))))
60 :element-type (array-element-type img))))
4597199 @slyrus added gamma functions and copy-image
authored Feb 8, 2011
61 (loop for i below ymax
62 do (loop for j below xmax
657e528 @slyrus added crop-image and exported crop-image and copy-image
authored Feb 20, 2011
63 do (setf (pixel new-image i j) (pixel img i j))))
64 new-image)))
65
66 (defun crop-image (img y1 x1 y2 x2)
67 (with-image-bounds (ymax xmax channels)
68 img
3794024 @slyrus fix crop-image to use new size, not original size
authored Feb 21, 2011
69 (declare (ignore ymax xmax))
c129cc7 @slyrus crop-image now assumes that the coordinates are specified as left-clo…
authored Feb 23, 2011
70 (let ((new-rows (- y2 y1))
71 (new-cols (- x2 x1)))
3794024 @slyrus fix crop-image to use new size, not original size
authored Feb 21, 2011
72 (let ((new-image (make-array
73 (cons new-rows (cons new-cols (when channels (list channels))))
74 :element-type (array-element-type img))))
75 (loop for i-src from y1 below y2
76 for i-dest below new-rows
77 do (loop for j-src from x1 below x2
78 for j-dest below new-cols
79 do
657e528 @slyrus added crop-image and exported crop-image and copy-image
authored Feb 20, 2011
80 (setf (pixel new-image i-dest j-dest) (pixel img i-src j-src))))
3794024 @slyrus fix crop-image to use new size, not original size
authored Feb 21, 2011
81 new-image))))
4597199 @slyrus added gamma functions and copy-image
authored Feb 8, 2011
82
b081af3 @slyrus add a force-simple arg to map-array so that we can get simple arrays …
authored Mar 23, 2011
83 (defun map-array (fn array &key
84 (element-type (array-element-type array))
85 (adjustable (adjustable-array-p array))
86 (force-simple t))
87 (let ((len (reduce #'* (array-dimensions array))))
88 (if force-simple
89 (let* ((disp (make-array len
90 :displaced-to array))
91 (vec (map `(vector ,element-type) fn disp))
92 (dest (make-array (array-dimensions array)
93 :adjustable adjustable
94 :element-type element-type)))
95 (loop for i below len
96 do (setf (row-major-aref dest i)
97 (elt vec i)))
98 dest)
99 (let* ((disp (make-array len :displaced-to array)))
100 (make-array (array-dimensions array)
101 :element-type element-type
102 :displaced-to (map `(vector ,element-type) fn disp))))))
0846f8d @slyrus added discrete-convolution (and blur, sharpen)
authored Mar 2, 2011
103
104 (defun trim-image (img y-pixels x-pixels)
105 (with-image-bounds (height width)
106 img
107 (crop-image img y-pixels x-pixels (- height y-pixels) (- width x-pixels))))
108
Something went wrong with that request. Please try again.