Plaster
New
List
Login
text
apl
aspx
asterisk
brainfuck
c
c++hdr
c++src
cassandra
ceylon
clojure
clojurescript
cmake
cobol
coffeescript
common-lisp
crystal
csharp
css
cypher-query
cython
d
dart
diff
django
dockerfile
dylan
ebnf
ecl
ecmascript
edn
eiffel
ejs
elm
erb
erlang
ez80
factor
fcl
feature
forth
fortran
fragment
gfm
go
gql
groovy
gss
haml
handlebars-template
haskell
haxe
hive
html
http
httpd-php
httpd-php-open
hxml
ini
java
javascript
json
jsp
jsx
julia
kotlin
latex
less
literate-haskell
lua
mariadb
markdown
mbox
mirc
mscgen
msgenny
mssql
mumps
mysql
n-triples
nesc
nginx-conf
nsis
objectivec
octave
oz
pascal
perl
pgp
pgp-keys
pgp-signature
pgsql
php
pig
plsql
properties
protobuf
puppet
python
q
rpm-changes
rpm-spec
rsrc
ruby
rustsrc
sas
sass
scala
scheme
scss
sieve
slim
smarty
solr
soy
sparql-query
spreadsheet
sql
squirrel
stex
styl
swift
systemverilog
tcl
textile
tiddlywiki
tiki
tlv
tornado
ttcn-asn
ttcn-cfg
turtle
twig
typescript
typescript-jsx
vb
vbscript
velocity
verilog
vertex
vhdl
vue
webidl
xml
xml-dtd
xquery
xu
yaml
z80
default
Visibility:
public
unlisted
private
(deftype rgb () '(simple-array (unsigned-byte 8) (3))) (deftype hsv () '(simple-array (single-float 0.0e0 1.0e0) (3))) (define-condition hsv-type-error (type-error) ((bugged-vector :initarg :bugged :accessor bugged-hsv-vector)) (:report (lambda (condition stream) (format stream "all elements of HSV must be floats between 0.0 and 1.0: ~A" (bugged-hsv-vector condition))))) (declaim (inline rgb hsv rgb->hsv hsv->rgb rotate-hsv rotate-rgb)) (defun rgb (r g b) (declare (optimize speed)) (make-array '(3) :element-type '(unsigned-byte 8) :initial-contents (list r g b))) (defun hsv (h s v) (declare (optimize speed)) (make-array '(3) :element-type '(single-float 0.0e0 1.0e0) :initial-contents (list h s v))) (declaim (ftype (function (rgb) hsv) rgb->hsv)) (defun rgb->hsv (a) ;;(declare (optimize speed)) (declare (type rgb a)) (let* ((r (* (aref a 0) (coerce 1/255 'float))) (g (* (aref a 1) (coerce 1/255 'float))) (b (* (aref a 2) (coerce 1/255 'float))) (max (max r g b)) (min (min r g b)) (v max)) (if (= max min) (make-array '(3) :element-type '(single-float 0.0e0 1.0e0) :initial-contents (list 0.0 0.0 v)) (let ((tmp (- max min)) (s (/ (- max min) max)) h) (cond ((= r max) (setf h (- (/ (- max b) tmp) (/ (- max g) tmp)))) ((= g max) (setf h (+ 2.0 (- (/ (- max r) tmp) (/ (- max b) tmp))))) (t (setf h (+ 4.0 (- (/ (- max g) tmp) (/ (- max r) tmp)))))) (let ((foo (* h (coerce 1/6 'float)))) (setf h (mod foo 1))) (hsv h s v))))) (declaim (ftype (function (hsv) rgb) hsv->rgb)) (defun hsv->rgb (a) (declare (optimize speed)) (declare (type hsv a)) (let ((h (aref a 0)) (s (aref a 1)) (v (aref a 2))) (labels ((unfloat (c) (declare (type (single-float 0.0e0 1.0e0) c)) (coerce (round (* c 255)) 'integer)) (rgb-from-floats (r g b) (declare (type (single-float 0.0e0 1.0e0) r g b)) (make-array 3 :element-type '(unsigned-byte 8) :initial-contents (list (unfloat r) (unfloat g) (unfloat b))))) (the rgb (if (= s 0.0) (rgb-from-floats v v v) (multiple-value-bind (i f) (truncate (* h 6.0)) (declare (type (integer 0 6) i)) (let* ((p (* v (- 1.0 s))) (q (* v (- 1.0 (* s f)))) (tv (* v (- 1.0 (* s (- 1.0 f)))))) (cond ((= i 1) (rgb-from-floats q v p)) ((= i 2) (rgb-from-floats p v tv)) ((= i 3) (rgb-from-floats p q v)) ((= i 4) (rgb-from-floats tv p v)) ((= i 5) (rgb-from-floats v p q)) (t (rgb-from-floats v tv p)))))))))) ;;; (hsv->rgb (rotate-hsv (rgb->hsv color) 180)) == (complement-rgb color) (defun rotate-hsv (a rotation) (declare (optimize speed)) (declare (type hsv a) (type (integer 0 359) rotation)) (let ((h (aref a 0)) (s (aref a 1)) (v (aref a 2)) (scaled-rotation (* rotation (coerce 1/360 'float)))) (the hsv (hsv (mod (+ h scaled-rotation) 1.0) s v)))) (defun rotate-rgb (a rotation) ;;(declare (optimize speed)) (declare (type rgb a) (type (integer 0 359) rotation)) (let ((hsv (print (rgb->hsv a)))) (declare (type hsv hsv)) (let ((rotated-hsv (print (rotate-hsv hsv rotation)))) (declare (type hsv rotated-hsv)) (let (rgb (print (hsv->rgb rotated-hsv))) (declare (type rgb rgb)) rgb))))