Changeset 1342

Show
Ignore:
Timestamp:
03/01/05 20:24:29 (4 years ago)
Author:
hans
Message:

imageproc refaktoriert, das war ja alles supergruselig. Jetzt kann man
mit define-imageproc-operation neue Operationen definieren.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/bknr/src/packages.lisp

    r1324 r1342  
    466466   ;; imageproc 
    467467   imageproc 
     468   define-imageproc-handler 
    468469   imageproc-handler 
    469470    

  • trunk/bknr/src/web/imageproc-handler.lisp

    r1324 r1342  
    33(enable-interpol-syntax) 
    44 
    5 (defvar *imageproc-orig-image* nil) 
     5(defvar *imageproc-operations* (make-hash-table)) 
    66 
    7 (defun imageproc (operations input-image type 
    8                   &key (cache-sticky t)) 
    9   (if (null operations) 
    10       (progn 
    11         (unless (member type '(:jpg :jpeg)) 
    12           (when (true-color-p input-image) 
    13             #+nil(when (and *imageproc-orig-image* 
    14                             (or (< (image-width input-image) 
    15                                    (store-image-width *imageproc-orig-image*)) 
    16                                 (< (image-height input-image) 
    17                                    (store-image-height *imageproc-orig-image*)))) 
    18                    (true-color-to-palette :dither t :image input-image :colors-wanted 256)) 
    19              
    20             (true-color-to-palette :dither t :image input-image 
    21                                    :colors-wanted 256))) 
    22         (emit-image-to-browser *req* *ent* input-image type 
    23                                :cache-sticky cache-sticky)) 
    24       (let ((operation-and-args (mapcar #'(lambda (string) (if (equal "" string) nil string)) (split "," (car operations))))) 
    25         (ecase (make-keyword-from-string (first operation-and-args)) 
    26           (:double (imageproc-double (cdr operations) input-image type 
    27                                      (cdr operation-and-args))) 
    28           (:thumbnail (imageproc-thumbnail (cdr operations) input-image type 
    29                                            (cdr operation-and-args))) 
    30           (:cell (imageproc-cell (cdr operations) input-image type 
    31                                  (cdr operation-and-args))) 
    32           (:color (imageproc-color (cdr operations) input-image type 
    33                                    (cdr operation-and-args))))))) 
     7(defun register-imageproc-operation (name function) 
     8  (setf (gethash (make-keyword-from-string (symbol-name name)) *imageproc-operations*) function)) 
     9 
     10(defmacro define-imageproc-handler (name (&rest arguments) &body body) 
     11  `(prog1 
     12    (eval-when (:compile-toplevel :execute) 
     13      (defun ,name (,@arguments) ,@body)) 
     14    (eval-when (:compile-toplevel :load-toplevel :execute) 
     15      (register-imageproc-operation ',name (fdefinition ',name))))) 
     16 
     17(defun apply-imageproc-operation (operation-name args image) 
     18  (apply (or (gethash (make-keyword-from-string operation-name) *imageproc-operations*) 
     19             (error "invalid imageproc operation name ~A" operation-name)) 
     20         image args)) 
     21 
     22(defun imageproc (image operations &key cache-sticky) 
     23  (with-store-image (input-image image) 
     24    (setf (save-alpha-p :image input-image) t) 
     25    (let ((working-image input-image)) 
     26      (format t "; (eq working-image input-image) => ~A~%" (eq working-image input-image)) 
     27      (dolist (operation operations) 
     28        (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) 
     29          (let ((returned-image (apply-imageproc-operation operation-name args working-image))) 
     30            (format t "; (eq returned-image input-image) => ~A~%" (eq returned-image input-image)) 
     31            (unless (not returned-image) 
     32              (unless (or (eq working-image returned-image) 
     33                          (eq working-image input-image)) 
     34                (format t "; destroy image~%") (finish-output) 
     35                (destroy-image working-image)) 
     36              (setf working-image returned-image))))) 
     37      (emit-image-to-browser *req* *ent* working-image (if (true-color-p working-image) :jpg :png) 
     38                             :cache-sticky cache-sticky) 
     39      (unless (eq working-image input-image) 
     40        (destroy-image working-image))))) 
     41#+(or) 
     42(unless (member type '(:jpg :jpeg)) 
     43  (when (true-color-p input-image) 
     44    (true-color-to-palette :dither t :image input-image 
     45                       :colors-wanted 256))) 
    3446 
    3547(defparameter *cell-border-width* 5) 
    3648 
    37 (defun imageproc-cell (operations input-image type &rest args) 
    38   (destructuring-bind 
    39         (&optional bgcolor cell-width cell-height border-width) 
    40       (car args) 
    41     (setq cell-width (parse-integer cell-width)) 
    42     (setq cell-height (parse-integer cell-height)) 
    43     (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor nil)) 
    44     (setq border-width (if border-width (parse-integer border-width) *cell-border-width*)) 
    45     (let* ((width (image-width input-image)) 
    46            (height (image-height input-image)) 
    47            (ratio (max (/ width (- cell-width (* border-width 2))) 
    48                        (/ height (- cell-height (* border-width 2))))) 
    49            (thumbnail-width (min width (round (/ width ratio)))) 
    50            (thumbnail-height (min height (round (/ height ratio)))) 
    51            (x-offset (round (/ (- cell-width thumbnail-width) 2))) 
    52            (y-offset (round (/ (- cell-height thumbnail-height) 2)))) 
    53       (with-image (cell cell-width cell-height t) 
    54         (with-default-image (cell) 
    55           (let ((color (if bgcolor 
    56                            (parse-color bgcolor) 
    57                            (allocate-color 20 40 20)))) 
    58             (fill-image 0 0 :color color) 
    59             (copy-image input-image cell 
    60                         0 0 
    61                         x-offset 
    62                         y-offset 
    63                         width height 
    64                         :resize t :resample t 
    65                         :dest-width thumbnail-width :dest-height thumbnail-height) 
    66             (unless bgcolor 
    67               (setf (transparent-color) color) 
    68               (let ((cr (ldb (byte 8 16) color)) 
    69                     (cg (ldb (byte 8 8) color)) 
    70                     (cb (ldb (byte 8 0) color))) 
    71                 (flet ((color-distance (c) 
    72                          (+ (abs (- (ldb (byte 8 16) c) cr)) 
    73                             (abs (- (ldb (byte 8 8) c) cg)) 
    74                             (abs (- (ldb (byte 8 0) c) cb))))) 
    75                   (do-pixels () 
    76                     (when (< (color-distance (raw-pixel)) 6) 
    77                       (setf (raw-pixel) color))))))) 
    78           (imageproc operations cell type)))))) 
    79    
    80 (defun imageproc-thumbnail (operations input-image type &rest args) 
    81   (destructuring-bind 
    82         (&optional bgcolor max-width max-height) 
    83       (car args) 
    84     (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor "ffffff")) 
    85     (setf max-width (if max-width (parse-integer max-width) *thumbnail-max-width*)) 
    86     (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*)) 
    87     (let ((width (image-width input-image)) 
    88           (height (image-height input-image))) 
    89       (if (and (>= max-width width) 
    90                (>= max-height height)) 
    91           (imageproc operations input-image type) 
    92           (let* ((ratio (max (/ width max-width) 
    93                              (/ height max-height))) 
    94                  (thumbnail-width (round (/ width ratio))) 
    95                  (thumbnail-height (round (/ height ratio)))) 
    96             (with-image (thumbnail thumbnail-width 
    97                                    thumbnail-height 
    98                                    t) 
    99               (with-default-image (thumbnail) 
    100                 (fill-image 0 0 :color (parse-color bgcolor)) 
    101                 (copy-image input-image thumbnail 
    102                             0 0 0 0 
    103                             width height 
    104                             :resize t :resample t 
    105                             :dest-width thumbnail-width :dest-height thumbnail-height)) 
    106               (imageproc operations thumbnail type))))))) 
    107  
    108 (defun imageproc-double (operations input-image type args) 
     49(define-imageproc-handler cell (input-image &optional bgcolor cell-width cell-height border-width) 
     50  (setq cell-width (parse-integer cell-width)) 
     51  (setq cell-height (parse-integer cell-height)) 
     52  (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor nil)) 
     53  (setq border-width (if border-width (parse-integer border-width) *cell-border-width*)) 
    10954  (let* ((width (image-width input-image)) 
    11055         (height (image-height input-image)) 
    111          (ratio (/ 1 (if args (parse-integer (first args)) 2))) 
     56         (ratio (max (/ width (- cell-width (* border-width 2))) 
     57                     (/ height (- cell-height (* border-width 2))))) 
     58         (thumbnail-width (min width (round (/ width ratio)))) 
     59         (thumbnail-height (min height (round (/ height ratio)))) 
     60         (x-offset (round (/ (- cell-width thumbnail-width) 2))) 
     61         (y-offset (round (/ (- cell-height thumbnail-height) 2))) 
     62         (cell (create-image cell-width cell-height t))) 
     63    (with-default-image (cell) 
     64      (let ((color (if bgcolor 
     65                       (parse-color bgcolor) 
     66                       (allocate-color 20 40 20)))) 
     67        (fill-image 0 0 :color color) 
     68        (copy-image input-image cell 
     69                    0 0 
     70                    x-offset 
     71                    y-offset 
     72                    width height 
     73                    :resize t :resample t 
     74                    :dest-width thumbnail-width :dest-height thumbnail-height) 
     75        (unless bgcolor 
     76          (setf (transparent-color) color) 
     77          (let ((cr (ldb (byte 8 16) color)) 
     78                (cg (ldb (byte 8 8) color)) 
     79                (cb (ldb (byte 8 0) color))) 
     80            (flet ((color-distance (c) 
     81                     (+ (abs (- (ldb (byte 8 16) c) cr)) 
     82                        (abs (- (ldb (byte 8 8) c) cg)) 
     83                        (abs (- (ldb (byte 8 0) c) cb))))) 
     84              (do-pixels () 
     85                (when (< (color-distance (raw-pixel)) 6) 
     86                  (setf (raw-pixel) color)))))))) 
     87    cell)) 
     88   
     89(define-imageproc-handler thumbnail (input-image &optional bgcolor max-width max-height) 
     90  (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor "ffffff")) 
     91  (setf max-width (if max-width (parse-integer max-width) *thumbnail-max-width*)) 
     92  (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*)) 
     93  (let ((width (image-width input-image)) 
     94        (height (image-height input-image))) 
     95    (when (or (< max-width width) 
     96              (< max-height height)) 
     97      (let* ((ratio (max (/ width max-width) 
     98                         (/ height max-height))) 
     99             (thumbnail-width (round (/ width ratio))) 
     100             (thumbnail-height (round (/ height ratio))) 
     101             (thumbnail (create-image thumbnail-width 
     102                                      thumbnail-height 
     103                                      t))) 
     104        (with-default-image (thumbnail) 
     105          (fill-image 0 0 :color (parse-color bgcolor)) 
     106          (copy-image input-image thumbnail 
     107                      0 0 0 0 
     108                      width height 
     109                      :resize t :resample t 
     110                      :dest-width thumbnail-width :dest-height thumbnail-height)) 
     111        thumbnail)))) 
     112 
     113(define-imageproc-handler double (input-image &optional (times "2")) 
     114  (let* ((width (image-width input-image)) 
     115         (height (image-height input-image)) 
     116         (ratio (/ 1 (parse-integer times))) 
    112117         (double-image-width (round (/ width ratio))) 
    113          (double-image-height (round (/ height ratio)))) 
     118         (double-image-height (round (/ height ratio))) 
     119         (double-image (create-image double-image-width double-image-height nil))) 
    114120    ;;; XXX no truecolor upscaled pictures... 
    115     (with-image (double-image double-image-width double-image-height nil) 
    116       (with-default-image (double-image) 
    117         (setf (transparent-color double-image) 
    118               (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) 
    119         (fill-image 0 0 :color (transparent-color double-image)) 
    120         (copy-image input-image double-image 
    121                     0 0 0 0 width height 
    122                     :resize t :resample t 
    123                     :dest-width double-image-width :dest-height double-image-height)) 
    124       (imageproc operations double-image type)))) 
     121    (with-default-image (double-image) 
     122      (setf (transparent-color double-image) 
     123            (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) 
     124      (fill-image 0 0 :color (transparent-color double-image)) 
     125      (copy-image input-image double-image 
     126                  0 0 0 0 width height 
     127                  :resize t :resample t 
     128                  :dest-width double-image-width :dest-height double-image-height)) 
     129    double-image)) 
    125130 
    126 (defun imageproc-color (operations input-image type colorstr) 
     131(define-imageproc-handler color (input-image &rest color-mappings) 
    127132  (with-default-image (input-image) 
    128     (let ((colors (loop for (old new) on colorstr by #'cddr 
     133    (let ((colors (loop for (old new) on color-mappings by #'cddr 
    129134                        collect (cons (parse-color old) (parse-color new))))) 
    130           #+nil(format t "color: ~A~%" colors) 
    131           (do-pixels (input-image) 
    132             (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) 
    133               (when (cdr new-color) 
    134                 (setf (raw-pixel) (cdr new-color)))))) 
    135     (imageproc operations input-image type))) 
    136  
    137 (defclass imageproc-handler (image-handler) 
    138   ()) 
    139  
    140 (defmethod handle-object ((page-handler imageproc-handler) (image (eql nil)) req ent) 
    141   (error-404 req ent)) 
    142  
    143 (defvar *operation-aliases* '(("t610" "cell,ffffff,128,160,0"))) 
    144  
    145 (defmethod handle-object ((page-handler imageproc-handler) image req ent) 
    146   (let ((operations (cdr (decoded-handler-path page-handler req)))) 
    147     (if operations 
    148         (destructuring-bind 
    149               (&optional last-operation (output-type :png)) 
    150             (split #?r"[,.](?=(?i:jpe?g|gif|png)$)" (first (last operations))) 
    151           #+(or) (format t ";; operations: ~A last-operation: ~A output-type: ~A~%" operations last-operation output-type) 
    152           (when (stringp output-type) 
    153             (setf output-type (make-keyword-from-string output-type)) 
    154             (setf (first (last operations)) last-operation)) 
    155           (setq operations (loop for operation in operations 
    156                                  collect (or (cadr (find operation *operation-aliases* :test #'string-equal :key #'car)) 
    157                                              operation))) 
    158           (with-store-image (input-image image) 
    159             (setf (save-alpha-p :image input-image) t) 
    160             (let ((*imageproc-orig-image* image)) 
    161               (imageproc operations input-image output-type)))) 
    162         (with-store-image (input-image image) 
    163           (emit-image-to-browser req ent input-image (blob-type image)))))) 
     135      #+nil(format t "color: ~A~%" colors) 
     136      (do-pixels (input-image) 
     137        (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) 
     138          (when (cdr new-color) 
     139            (setf (raw-pixel) (cdr new-color))))))) 
     140  input-image) 
    164141 
    165142(defun image-url (image &key process (prefix "/image")) 
    …… 
    183160                                    :exact nil :resolve t :image image))) 
    184161          color)))) 
     162 
     163(defclass imageproc-handler (image-handler) 
     164  ()) 
     165 
     166(defmethod handle-object ((page-handler imageproc-handler) (image (eql nil)) req ent) 
     167  (error-404 req ent)) 
     168 
     169(defmethod handle-object ((page-handler imageproc-handler) image req ent) 
     170  (let ((operations (cdr (decoded-handler-path page-handler req)))) 
     171    (if operations 
     172        (imageproc image operations) 
     173        (with-store-image (input-image image) 
     174          (emit-image-to-browser req ent input-image (blob-type image)))))) 
     175