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