1(* 2 Copyright 2006,2010,2011 by Mark Weyer 3 Maintenance modifications 2008,2011 by the cuyo developers 4 5 This program is free software; you can redistribute it and/or modify 6 it under the terms of the GNU General Public License as published by 7 the Free Software Foundation; either version 2 of the License, or 8 (at your option) any later version. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 GNU General Public License for more details. 14 15 You should have received a copy of the GNU General Public License 16 along with this program; if not, write to the Free Software 17 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 18*) 19 20open Farbe 21open Helfer 22 23module Rgb = Vektor.Vektor(Natmod.Drei) 24module Rgba = Vektor.Vektor(Natmod.Vier) 25 26type punkt = float * float 27 28type bildchen = int * int * (punkt -> farbe) 29 30let monochrom farbe breite hoehe = breite, hoehe, function p -> farbe 31 32let spiegel_x (breite,hoehe,farben) = 33 let breite_f = float_of_int breite in 34 breite, hoehe, 35 function x,y -> farben (breite_f-.x,y) 36 37let kombiniere_bildchen breite hoehe einzelne = 38 breite, hoehe, 39 function (x,y) -> List.fold_left 40 (function farbe -> function (x0,y0,(breite,hoehe,farben)) -> 41 if (float_of_int x0)<=x && (x<=(float_of_int (x0+breite))) 42 && (float_of_int y0)<=y && (y<=(float_of_int (y0+hoehe))) 43 then farben (x-.(float_of_int x0), y-.(float_of_int y0)) 44 else farbe) 45 durchsichtig 46 einzelne 47 48let ueberlagerung (b,h,funten) (b',h',foben) maske = 49 match maske with 50 | None -> (b,h, fun p -> 51 let o = foben p in 52 let d = nur_durchsichtig o in 53 if d=0.0 then o else misch2 o (funten p) d) 54 | Some (b'',h'',fmaske) -> (b,h, fun p -> 55 let d = nur_durchsichtig (fmaske p) in 56 if d=0.0 57 then foben p 58 else if d=1.0 59 then funten p 60 else misch2 (foben p) (funten p) d) 61 62 63 64 65type pixelbild = int * int * farbe array array 66 67let berechne aufloesung (breite,hoehe,farben) = 68 let breite,hoehe = breite*aufloesung,hoehe*aufloesung in 69 let aufloesung = 1.0/.(float_of_int aufloesung) in 70 breite,hoehe,Array.init hoehe (function y -> 71 let yf = ((float_of_int (hoehe-y))-.0.5)*.aufloesung in 72 Array.init breite (function x -> 73 farben (((float_of_int x)+.0.5)*.aufloesung, yf))) 74 75let abstrahiere aufloesung (breite,hoehe,pixel) = 76 breite/aufloesung, hoehe/aufloesung, 77 let auff = float_of_int aufloesung in 78 let limitx,limity = breite-1, hoehe-1 in 79 let runde limit f = min limit (int_of_float (floor (f*.auff))) in 80 (fun (x,y) -> pixel.(limity-runde limity y).(runde limitx x)) 81 82 83let ausschnitt x0 y0 x1 y1 (b,h,f) = 84 (x1-x0,y1-y0, 85 Array.init (y1-y0) (fun y -> Array.init (x1-x0) (fun x -> 86 f.(y+y0).(x+x0)))) 87 88let kleb hori (b1,h1,f1) (b2,h2,f2) = if hori 89 then (b1+b2, h1, 90 Array.init h1 (fun y -> Array.init (b1+b2) (fun x -> if x<b1 91 then f1.(y).(x) 92 else f2.(y).(x-b1)))) 93 else (b1, h1+h2, 94 Array.init (h1+h2) (fun y -> Array.init b1 (fun x -> if y<h1 95 then f1.(y).(x) 96 else f2.(y-h1).(x)))) 97 98 99let list_n n = 100 let rec doit i = if i=n then [] else i::(doit (i+1)) in 101 doit 0 102 103let durchschnitt n (w,h,pixel) = (w/n, h/n, 104 let liste = list_n n in 105 Array.init (h/n) (fun y -> Array.init (w/n) (fun x -> 106 misch (List.concat (List.map 107 (fun i -> List.map 108 (fun j -> 1.0, pixel.(y*n+i).(x*n+j)) 109 liste) 110 liste))))) 111 112let extrahiere_farben (breite,hoehe,pixel) = 113 let n,k = Array.fold_left (Array.fold_left (fun (n,k) -> fun farbe -> 114 if FarbMap.mem farbe k 115 then n,k 116 else n+1, FarbMap.add farbe n k)) 117 (0,FarbMap.empty) 118 pixel in 119 let p = Array.make n schwarz in (* schwarz ist ein dummy *) 120 FarbMap.iter 121 (fun farbe -> fun i -> p.(i)<-farbe) 122 k; 123 p,k 124 125let extrahiere_verteilung (breite,hoehe,pixel) = 126 let n,v = Array.fold_left (Array.fold_left 127 (fun (n,v) -> fun farbe -> if FarbMap.mem farbe v 128 then n, FarbMap.add farbe ((FarbMap.find farbe v)+1) v 129 else n+1, FarbMap.add farbe 1 v)) 130 (0,FarbMap.empty) pixel in 131 let v' = Array.make n (schwarz,0) in 132 ignore (FarbMap.fold 133 (fun farbe -> fun anzahl -> fun n -> 134 v'.(n) <- (farbe,anzahl); 135 n+1) 136 v 0); 137 v' 138 139 140type farbreduktions_methode = 141| Heuristik_mittlerer_euklidischer 142| Heuristik_maximaler_euklidischer 143 144let reduziere_farben methode mussrein anzahl bild = match methode with 145 | Heuristik_mittlerer_euklidischer -> 146 reduziere_farben1 mussrein (extrahiere_verteilung bild) anzahl 147 | Heuristik_maximaler_euklidischer -> 148 reduziere_farben2 mussrein (fst (extrahiere_farben bild)) anzahl 149 150 151 152let xpm_zeichen = " #@*+-=~/.,:;_&%$!?|" ^ 153 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ^ 154 "'`^(){}[]<>" 155 156let anz_xpm_zeichen = String.length xpm_zeichen 157 158 159let gib_xpm_aus h palette farbsuche dateiname (breite,hoehe,pixel) = 160 let anz_farb = Array.length palette in 161 let kodier_breite = 162 let rec log n = if n>anz_xpm_zeichen 163 then 1+(log (n/anz_xpm_zeichen)) 164 else 1 in 165 log anz_farb in 166 let kodiere i = 167 let rec kodiere_rest rest_laenge rest_i = 168 if rest_laenge=0 169 then "" 170 else (kodiere_rest (rest_laenge-1) (rest_i/anz_xpm_zeichen)) 171 ^(String.sub xpm_zeichen (rest_i mod anz_xpm_zeichen) 1) in 172 kodiere_rest kodier_breite i in 173 174 let datei = open_out dateiname in 175 let os = output_string datei in 176 let oi i = os (string_of_int i) in 177 178 let hex n = 179 let hex_ziffer n = String.sub "0123456789ABCDEF" n 1 in 180 (hex_ziffer (n/16))^(hex_ziffer (n mod 16)) in 181 let hex f = os (hex (truncate (255.0*.f+.0.5))) in 182 183 os "/* XPM */\n"; 184 os "static char * noname[] = {\n"; 185 os "\""; oi breite; os " "; oi hoehe; os " "; 186 oi anz_farb; os " "; oi kodier_breite; os "\""; 187 ignore (Array.fold_left 188 (function i -> function f -> 189 os ",\n\""; os (kodiere i); os " c "; 190 (if f=durchsichtig 191 then os "None" 192 else if f=hintergrund 193 then os "Background" 194 else 195 let rgb = zu_rgb h h f in 196 os "#"; hex (Rgb.koord rgb 0); 197 hex (Rgb.koord rgb 1); hex (Rgb.koord rgb 2)); 198 os "\""; 199 i+1) 200 0 201 palette); 202 for y = 0 to hoehe-1 do 203 os ",\n\""; 204 for x = 0 to breite-1 do 205 os (kodiere (farbsuche pixel.(y).(x))) 206 done; 207 os "\""; 208 done; 209 os "};\n"; 210 close_out datei 211 212 213let gib_xpm_aus_exakt h name bild = 214 let palette,karte = extrahiere_farben bild in 215 gib_xpm_aus h palette (fun farbe -> FarbMap.find farbe karte) name bild 216 217let gib_xpm_aus_palette h palette = 218 let index = mach_index palette in 219 gib_xpm_aus h palette (naechste_farbe palette index) 220 221let gib_xpm_aus_anzahl ?(methode=Heuristik_maximaler_euklidischer) 222 h anzahl name bild = 223 gib_xpm_aus_palette h (reduziere_farben methode [| |] anzahl bild) name bild 224 225let gib_xpm_aus ?methode h = gib_xpm_aus_anzahl ?methode h anz_xpm_zeichen 226 227 228let gib_ppm_aus name (breite,hoehe,pixel) = 229 let schw = rgb_grau 0.0 in 230 let datei = open_out name in 231 let os = output_string datei in 232 let oi i = os (string_of_int i) in 233 let ob = output_byte datei in 234 os "P6\n"; 235 oi breite; os " "; 236 oi hoehe; os "\n"; 237 os "255\n"; 238 Array.iter (Array.iter (fun farbe -> 239 let rgb = zu_rgb schw schw farbe in 240 for i=0 to 2 do 241 ob (int_of_float (floor 242 ((max 0.0 (min 1.0 (Rgb.koord rgb i)))*.255.0 +. 0.5))) 243 done)) 244 pixel; 245 close_out datei 246 247 248 249exception Falscher_TupleType 250 251let lies_xpm dateiname = 252 let lex = Lexing.from_channel (open_in dateiname) in 253 let lies_zeile u = Xpmlex.xpm lex in 254 let zeile1 = Lexing.from_string (lies_zeile ()) in 255 let zahl u = Xpmlex.erstezeile zeile1 in 256 let breite = zahl () in 257 let hoehe = zahl () in 258 let anz_farben = zahl () in 259 let charpp = zahl () in 260 let farben = Array.to_list (Array.init anz_farben (function i -> 261 let zeile = lies_zeile () in 262 prefix zeile charpp, 263 Xpmlex.farbzeilenrest (Lexing.from_string 264 (coprefix zeile charpp)))) in 265 breite,hoehe,Array.init hoehe (function y -> 266 let zeile = lies_zeile () in 267 Array.init breite (function x -> 268 List.assoc (String.sub zeile (x*charpp) charpp) farben)) 269 270let lies_ppm dateiname = 271 let (breite,hoehe,tiefe,maxval,daten),typ = 272 Pam.read_pam (open_in dateiname) in 273 let maxvalf = float_of_int maxval in 274 if tiefe!=3 275 then raise Falscher_TupleType 276 else 277 breite,hoehe, 278 Array.map 279 (Array.map (function d -> 280 von_rgb (Rgb.aus_array (Array.map 281 (fun i -> (float_of_int i)/.maxvalf) d)))) 282 daten 283 284let lies_pam dateiname = 285 let (breite,hoehe,tiefe,maxval,daten),typ = 286 Pam.read_pam (open_in dateiname) in 287 let maxvalf = float_of_int maxval in 288 if tiefe!=4 289 then raise Falscher_TupleType 290 else 291 breite,hoehe, 292 Array.map 293 (Array.map (function d -> 294 von_rgba (Rgba.aus_array (Array.map 295 (fun i -> (float_of_int i)/.maxvalf) d)))) 296 daten 297 298 299