<*+M2EXTENSIONS *>
<*+STORAGE *>
<*-CHECKDIV *>
<*-CHECKRANGE *>
<*-COVERFLOW *>
<*-IOVERFLOW*>
<*-PROCINLINE*>
<*+NOPTRALIAS*>
<*-CHECKNIL *>
<*-CHECKINDEX*>
<*-CHECKDINDEX *>
<*-CHECKSET*>
<*CPU="PENTIUM"*>
<* IF __GEN_C__ THEN *>
  <*+COMMENT*>
  <*+GENCTYPES*>
  <*-PROCINLINE*>
  <*-GENDEBUG*>
  <*-LINENO*>
  <*-GENHISTORY*>
  <*-GENDATE*>
  <*+NOHEADER*>
<* ELSE *>
  <*-PROCINLINE*>
  <*+GENDEBUG*>
  <*+LINENO*>
  <*+GENHISTORY*>
  <*HEAPLIMIT="1000000000" *>
<* END *>

MODULE rgbjoin; (* read 3 bw pnm, adjust contrast, 0 is 0, >0 is >0 and join to colour pnm by OE5DXL *)

FROM osi IMPORT WrInt, WrLn, WrStr, WrStrLn, WrFixed, pi,
                arctan, exp, sin, cos, tan, sqrt, ln,
                OpenRead, OpenRW, Close, File, RdBin, WrBin, OpenWrite, FdValid;
FROM aprsstr IMPORT Append, IntToStr, Length, StrToFix, StrToInt, Assign;
FROM SYSTEM IMPORT SHIFT, CAST, ADR, CARD8, ADDRESS, INT16, CARD16;
FROM osi IMPORT NextArg;

CONST
      LF=012C;

TYPE  LUM=CARD16;
      pBLINE=POINTER TO ARRAY OF CHAR;
      COLPIX=RECORD r,g,b:LUM END;
      pCLINE=POINTER TO ARRAY OF COLPIX;
      pC8LINE=POINTER TO ARRAY OF CHAR;
 
VAR pbw:pBLINE;
    pc:pCLINE;
    pc8:pC8LINE;
    xsize, ysize, maxlum, maxr, maxg, maxb:CARDINAL;
    br, wr, bg, wg, bb, wb, saturate:INTEGER;
    h:ARRAY[0..1000] OF CHAR;
    rf, gf, bf, cf:INTEGER;
    lutr, lutg, lutb:ARRAY[0..65535] OF LUM;
    gamma:REAL;

PROCEDURE Err(text-:ARRAY OF CHAR);
BEGIN
  WrStr("rgbjoin: "); WrStr(text); WrStrLn(" error abort");
  HALT
END Err;

PROCEDURE sq(x:REAL):REAL;
BEGIN RETURN x*x END sq;


PROCEDURE getline(f:INTEGER; VAR h:ARRAY OF CHAR);
VAR i:CARDINAL;
BEGIN
  i:=0;
  REPEAT
    IF RdBin(f, h[i], 1)<>1 THEN Err("image file eof") END;

    INC(i);
  UNTIL (i>=HIGH(h)) OR (h[i-1]=LF);
  h[i-1]:=0C;
END getline;


PROCEDURE Openbw(fn-:ARRAY OF CHAR; VAR f:INTEGER; VAR xs, ys, maxlum:CARDINAL):BOOLEAN;
VAR h:ARRAY[0..1000] OF CHAR;
    i:CARDINAL;
BEGIN
  f:=OpenRead(fn);
  IF f<0 THEN RETURN FALSE END;
  
  getline(f, h);
  IF (h[0]<>"P") OR (h[1]<>"5") OR (h[2]<>0C) THEN Close(f); RETURN FALSE END;

  REPEAT getline(f, h) UNTIL h[0]<>"#";
  i:=0;
  xs:=0;
  WHILE (h[i]>="0") & (h[i]<="9") DO xs:=xs*10+ORD(h[i])-ORD("0"); INC(i) END;
  WHILE (h[i]=" ") DO INC(i) END;
  ys:=0;
  WHILE (h[i]>="0") & (h[i]<="9") DO ys:=ys*10+ORD(h[i])-ORD("0"); INC(i) END;

  getline(f, h);
  maxlum:=0;
  i:=0;
  WHILE (h[i]>="0") & (h[i]<="9") DO maxlum:=maxlum*10+ORD(h[i])-ORD("0"); INC(i) END;
  RETURN TRUE
END Openbw;


PROCEDURE WrHead(f:INTEGER; xsize, ysize, maxlum:CARDINAL);
VAR  h,b:ARRAY[0..1000] OF CHAR;
BEGIN
  b[0]:="P";
  b[1]:="6";
  b[2]:=LF;
  b[3]:=0C;
  IntToStr(xsize, 0, h);
  Append(b,h);
  Append(b," ");
  IntToStr(ysize, 0, h); 
  Append(b,h);
  Append(b,LF);
  IntToStr(maxlum, 0, h);
  Append(b,h);
  Append(b,LF);
  WrBin(f, b, Length(b));
END WrHead;

PROCEDURE rcol(maxc:CARDINAL; VAR i:CARDINAL; VAR c:LUM; lut-:ARRAY OF LUM);
VAR lum:CARDINAL;
BEGIN
  IF maxc>=256 THEN
    lum:=ORD(pbw^[i])*256+ORD(pbw^[i+1]);
    INC(i, 2); 
  ELSE
    lum:=ORD(pbw^[i]);
    INC(i);
  END;
  c:=lut[lum];
END rcol;
 
PROCEDURE join;
VAR i, x, y, xr, xg, xb:CARDINAL;
BEGIN
  xr:=xsize;
  IF maxr>=256 THEN xr:=xsize*2 END;
  xg:=xsize;    
  IF maxg>=256 THEN xg:=xsize*2 END;    
  xb:=xsize;    
  IF maxb>=256 THEN xb:=xsize*2 END;    
  FOR y:=0 TO ysize-1 DO
    IF RdBin(rf, pbw^, xr)<>VAL(INTEGER, xr) THEN Err("eof red file") END;
    i:=0;
    FOR x:=0 TO xsize-1 DO rcol(maxr, i, pc^[x].r, lutr) END;
    IF RdBin(gf, pbw^, xg)<>VAL(INTEGER, xg) THEN Err("eof green file") END;
    i:=0;
    FOR x:=0 TO xsize-1 DO rcol(maxg, i, pc^[x].g, lutg) END;
    IF RdBin(bf, pbw^, xr)<>VAL(INTEGER, xr) THEN Err("eof blue file") END;
    i:=0;
    FOR x:=0 TO xsize-1 DO rcol(maxb, i, pc^[x].b, lutb) END;

    IF maxlum>=256 THEN
      FOR x:=0 TO xsize-1 DO
        pc8^[x*6  ]:=CHR(pc^[x].r DIV 256);
        pc8^[x*6+1]:=CHR(pc^[x].r MOD 256);
        pc8^[x*6+2]:=CHR(pc^[x].g DIV 256);
        pc8^[x*6+3]:=CHR(pc^[x].g MOD 256);
        pc8^[x*6+4]:=CHR(pc^[x].b DIV 256);
        pc8^[x*6+5]:=CHR(pc^[x].b MOD 256);
      END;
      WrBin(cf, pc8^, xsize*6);
    ELSE
      FOR x:=0 TO xsize-1 DO 
        pc8^[x*3  ]:=CHR(pc^[x].r);
        pc8^[x*3+1]:=CHR(pc^[x].g);
        pc8^[x*3+2]:=CHR(pc^[x].b);
      END;
      WrBin(cf, pc8^, xsize*3);
    END;
  END;
END join; 

PROCEDURE genlut(VAR lut:ARRAY OF LUM; gamma:REAL; black, white, max, maxc, sat:CARDINAL);

PROCEDURE fy(x, s:REAL):REAL;
VAR r:REAL;
BEGIN
  IF x<0.0 THEN RETURN 0.0 END; 
  IF x>1.0 THEN RETURN 1.0 END;
  r:=x/s;
  IF r<1.0 THEN RETURN r*r*0.5*s END;
  r:=(1.0-x)/s;
  IF r>1.0 THEN RETURN s*0.5+(x-s)*(1.0-s)/(1.0-s*2.0) END;
  RETURN 1.0-r*r*0.5*s;
END fy;

VAR i:CARDINAL;
    b,w,k,r,s:REAL;
BEGIN
  IF sat=0 THEN s:=0.0001 ELSE s:=VAL(REAL, sat)*0.005 END;
--FOR i:=0 TO 255 DO WrInt(VAL(INTEGER, fy(FLOAT(i)/256.0, s)*256.0+0.5), 4) END; WrStrLn("");

  IF white>max THEN white:=max END;
  IF black>max THEN black:=max END;

  b:=VAL(REAL, black);
  w:=VAL(REAL, white);
  IF w<>b THEN k:=1.0/(w-b) ELSE k:=MAX(REAL) END;

  lut[0]:=0;
  FOR i:=1 TO HIGH(lut) DO
    r:=fy((VAL(REAL,i)-b)*k, s);                                                (* saturation function *)
    IF r>0.0 THEN r:=exp(ln(r)/gamma)*VAL(REAL, maxc) END;                      (* gamma *)
    IF r<1.0 THEN r:=1.0 ELSIF r>VAL(REAL, maxc) THEN r:=VAL(REAL, maxc) END;   (* 0, 1..max *)
    lut[i]:=VAL(CARDINAL,r+0.5);
  END;
END genlut;


VAR xs, ys:CARDINAL;
    fn:ARRAY[0..1000] OF CHAR;

BEGIN
  NextArg(fn);
  IF (fn[0]=0C) OR (fn[0]="-") THEN
    WrStrLn("usage: <red.pnm> <black> <white> <green.pnm> <black> <white> <blue.pnm> <black> <white> <colour.pnm> <gamma> [<soft-saturate%>]");
  HALT END;

  IF NOT Openbw(fn, rf, xs, ys, maxr) THEN
    Assign(h, fn); Append(h, " open red file"); Err(h);
  END;
  IF (xs=0) OR (ys=0) THEN Assign(h, fn); Append(h, " size red file"); Err(h)END;      
  NextArg(h);
  IF NOT StrToInt(h, br) THEN Err("need red black level %") END;
  NextArg(h);
  IF NOT StrToInt(h, wr) THEN Err("need red while level %") END;        
  xsize:=xs;
  ysize:=ys;

  NextArg(fn);
  IF NOT Openbw(fn, gf, xs, ys, maxg) THEN
    Assign(h, fn); Append(h, " open green file"); Err(h);
  END;
  IF (xs=0) OR (ys=0) THEN Assign(h, fn); Append(h, " size green file"); Err(h); END;
  NextArg(h);
  IF NOT StrToInt(h, bg) THEN Err("need red black level %") END;
  NextArg(h);
  IF NOT StrToInt(h, wg) THEN Err("need red while level %") END;
  IF (xsize<>xs) OR (ysize<>ys) THEN
    Assign(h, fn); Append(h, " need same size imagee"); Err(h);
  END;
  maxlum:=255;
  IF (maxr>=256) OR (maxg>=256) OR (maxb>=256) THEN maxlum:=65535 END; 
 
  NextArg(fn);
  IF NOT Openbw(fn, bf, xs, ys, maxb) THEN
    Assign(h, fn); Append(h, " open blue file"); Err(h);
  END;
  IF (xs=0) OR (ys=0) THEN Assign(h, fn); Append(h, " size blue file") END;
  NextArg(h);
  IF NOT StrToInt(h, bb) THEN Err("need red black level %") END;
  NextArg(h);
  IF NOT StrToInt(h, wb) THEN Err("need red while level %") END;
  IF (xsize<>xs) OR (ysize<>ys) THEN
    Assign(h, fn); Append(h, " need same size imagee"); Err(h);
  END;

  NextArg(fn);
  cf:=OpenWrite(fn);
  IF cf<0 THEN Assign(h,fn); Append(h," file write"); Err(h); END;
  WrHead(cf, xsize, ysize, maxlum);

  NextArg(h);
  IF NOT StrToFix(gamma, h) THEN gamma:=1.0 END;
  IF (gamma<0.01) OR (gamma>100.0) THEN Err("gamma 0.01..100.0") END;

  NextArg(h);
  IF NOT StrToInt(h, saturate) THEN saturate:=0 END;
  IF saturate>100 THEN Err("saturation 0..100") END;

  NEW(pbw, xsize*2); IF pbw=NIL THEN Err("out of memory") END;
  NEW(pc, xsize); IF pc=NIL THEN Err("out of memory") END;
  NEW(pc8, xsize*6); IF pc=NIL THEN Err("out of memory") END;

  genlut(lutr, gamma, br, wr, maxr, maxlum, saturate);
  genlut(lutg, gamma, bg, wg, maxg, maxlum, saturate);
  genlut(lutb, gamma, bb, wb, maxb, maxlum, saturate);

  WrInt(maxr, 6); WrInt(maxg, 6); WrInt(maxb, 6); WrInt(maxlum, 6);
  WrInt(xsize, 8); WrInt(ysize, 8); WrStrLn("");
  join;
  Close(rf);
  Close(cf);
  Close(bf);
  Close(cf);
END rgbjoin.