OberonCore

MODULE МоиИзображ1;
   IMPORT L := StdLog,  In,  Math, Gr := i21eduTPGraphics, F := i21eduFiles, Files;

   TYPE Arr = POINTER TO ARRAY OF ARRAY OF INTEGER;
   VAR pic, pic1 : Arr;

   PROCEDURE RdPx() : INTEGER;
      VAR a, b, c:SHORTCHAR; 
   BEGIN
      F.ReadSChar(a); F.ReadSChar(b); F.ReadSChar(c);
      RETURN ORD(c)+ORD(b)*256+ORD(a)*65536
   END RdPx;
   
   (* Процедура чтения картинки из файла *)
   PROCEDURE ReadPict(name: Files.Name; VAR pic: Arr);
      VAR  i, j, h, w : INTEGER; sc:SHORTCHAR; c:CHAR;
   BEGIN
      F.Close;
      F.Open(name);
      FOR i  := 1  TO 9   DO   (* пропуск ненужных байтов заголовка *)
         F.ReadChar( c );
      END;
      F.ReadInt( w );
      L.String('ширина=');L.Int(w);  (* ширина картинки, точек *)
      F.ReadInt(h );
      L.String('  высота='); L.Int(h);    (* высота картинки, точек *)
      pic := NIL;  NEW(pic, h,w);       
      FOR  i := 1  TO 14 DO   (* пропуск ненужных байтов заголовка *)
         F.ReadChar(c);
      END;
      
      FOR  i := 0  TO h-1   DO
      (* чтение троек байтов строки картинки *)
         FOR  j := 0  TO w-1   DO
            pic[h-1- i, j] := RdPx();
         END;
         (* пропуск выравнивающих байтов в конце строки *)
         j := 1;
         WHILE  j <= w*3 MOD 4   DO
            F.ReadSChar( sc ); INC( j )
         END;
      END;
      F.Close;
   END ReadPict;

   (* Процедура отрисовки картинки *)
   PROCEDURE Picture(x, y :INTEGER; pic: Arr);
      VAR  i, j : INTEGER;
   BEGIN
      FOR  i := 0  TO LEN(pic, 0)-1   DO
         FOR  j := 0  TO LEN(pic, 1)-1   DO
            Gr.color :=  pic[i, j];
            Gr.PutPixel(x + j, y + i);
         END;
      END;
   END Picture;   

   (* Процедура перевода картинки в цветной негатив *)
   PROCEDURE Negativ( pic: Arr; VAR pic1 : Arr);
      VAR  i, j, r, g, b, s : INTEGER;
   BEGIN
      NEW(pic1, LEN(pic, 0),  LEN(pic, 1));
      FOR  i := 0  TO LEN(pic, 0)-1   DO
         FOR  j := 0  TO LEN(pic, 1)-1   DO
            r := pic[i, j] MOD 256;
            g := pic[i, j] DIV 256 MOD 256;
            b := pic[i, j] DIV 256 DIV 256;
            pic1[i, j] := 255 - r + 256 * (255 - g) + 256 * 256 * ( 255 - b)
         END;
      END;
   END Negativ;

   (* Процедура масштабирования картинки *)
   PROCEDURE Scale(k :INTEGER; pic: Arr; VAR pic1 : Arr);
      VAR  i, j, m, n : INTEGER;
   BEGIN
      NEW(pic1, LEN(pic, 0)*k,  LEN(pic, 1)*k);
      FOR  i := 0  TO LEN(pic, 0)-1   DO
         FOR  j := 0  TO LEN(pic, 1)-1   DO
            FOR m := 0 TO k-1  DO
               FOR  n := 0  TO k-1   DO
                  pic1[i*k+m, j*k+n]:=pic[i, j]
               END;
            END;
         END;
      END;
   END Scale;

   (* Процедура поворота картинки *)
   PROCEDURE Rotate(VAR a, b: Arr; right: BOOLEAN);
      VAR  i, j : INTEGER;
   BEGIN
      b:= NIL;
      NEW(b, LEN(a, 1),  LEN(a,0));
      FOR  i := 0  TO LEN(a, 0)-1   DO
         FOR  j := 0  TO LEN(a, 1)-1   DO
            b[j, LEN(a, 0)-1-i]:=a[i,j]
         END;
      END;
   END Rotate;

   PROCEDURE Делать*;
      VAR i, j, p, w, h,b,re,g  : INTEGER;   c: CHAR; r: REAL;
         sc:SHORTCHAR;
         cc: ARRAY 100 OF CHAR;
         p1, p2, p3: Arr; ff : ARRAY 3 OF ARRAY 3 OF INTEGER;
      
   BEGIN
      Gr.Clear;
      Gr.bkColor := 255;
      ReadPict('LEGO 8885.bmp', p1);
      Picture(10, 10, p1);
      Negativ(p1, p2);
      Picture(200, 10, p2);
      Scale(2, p1, p2);
      Picture(10, 200, p2);
      Rotate(p1,  p2, TRUE);
      Picture(400, 10, p2);
      Gr.Open
   END Делать;

END МоиИзображ1.