Skip to content


Subversion checkout URL

You can clone with
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

49 lines (44 sloc) 2.003 kB
(in-package :opticl)
(defun make-gamma-curve-lookup-table (gamma &key (bits 16))
"Returns an array of length 2^bits of type unsigned-byte of
length bits that contains where the kth element contains the
value (k/2^bits-1)^gamma * 2^bits-1. The resulting curve can be
used by the apply-gamma-curve to apply a gamma curve to an image
using a lookup table of gamma values, rather than computing the
appropriate value for each pixel."
(let ((curve (make-array `(,(ash 1 bits)) :element-type `(unsigned-byte ,bits)))
(maxval (1- (ash 1 bits))))
(let ((maxdouble (float maxval 0d0)))
(loop for i from 0 to maxval
(let ((val (truncate (* (expt (/ i maxdouble) gamma) maxdouble))))
(setf (aref curve i)
(cond ((> 0 val) 0)
((> val maxval) maxval)
(t val))))))
(defun apply-gamma-curve-lookup-table (image gamma-curve)
"applys a gamma curve (usually created with
make-gamma-curve-lookup-table to perform a gamma curve
operation on an image by looking up the values in a lookup
table, rather than computing them for eacho pixel"
(let ((image2 (copy-image image)))
(with-image-bounds (height width)
(loop for i from 0 below height
do (loop for j from 0 below width
do (let ((vals (multiple-value-list (pixel image i j))))
(setf (pixel image2 i j)
(map 'list
(lambda (v)
(aref gamma-curve v))
(defun apply-gamma (image gamma)
(let* ((bits (let ((type (array-element-type image)))
(when type (cadr type))))
(make-gamma-curve-lookup-table gamma
:bits (or bits 8))))
(apply-gamma-curve-lookup-table image gamma-curve)))
Jump to Line
Something went wrong with that request. Please try again.