Changeset 10 for trunk


Ignore:
Timestamp:
Sep 22, 2014, 3:07:02 AM (10 years ago)
Author:
chronos
Message:
  • Added: Zooming and moving image.
  • Added: Color format 4-bit gray.
  • Added: Image operation for generating test gradient image.
Location:
trunk
Files:
1 added
10 edited

Legend:

Unmodified
Added
Removed

  • trunk/ColorFormats/UColorGray1.pas

    r9 r10  
    4242  case Channel of
    4343    ccGray: Result := 0;
    44     else raise Exception.Create('Unsupported color channel');
     44    else Result := 0;
    4545  end;
    4646end;

  • trunk/Forms/UFormMain.lfm

    r7 r10  
    22  Left = 664
    33  Height = 640
    4   Top = 443
     4  Top = 382
    55  Width = 920
    66  Caption = 'LibrePaint'
    … …  
    88  ClientWidth = 920
    99  Menu = MainMenu1
     10  OnActivate = FormActivate
     11  OnCreate = FormCreate
     12  OnDestroy = FormDestroy
     13  OnShow = FormShow
    1014  LCLVersion = '1.3'
    1115  object PaintBox1: TPaintBox
    … …  
    1519    Width = 920
    1620    Align = alClient
     21    OnMouseDown = PaintBox1MouseDown
     22    OnMouseMove = PaintBox1MouseMove
     23    OnMouseUp = PaintBox1MouseUp
     24    OnMouseLeave = PaintBox1MouseLeave
     25    OnMouseWheelDown = PaintBox1MouseWheelDown
     26    OnMouseWheelUp = PaintBox1MouseWheelUp
    1727    OnPaint = PaintBox1Paint
    1828    OnResize = PaintBox1Resize
    … …  
    2333    Top = 588
    2434    Width = 920
    25     Panels = <>
     35    Panels = <   
     36      item
     37        Width = 50
     38      end>
     39    SimplePanel = False
    2640  end
    2741  object MainMenu1: TMainMenu
    … …  
    8599        Action = Core.AImageFlip
    86100      end
     101      object MenuItem19: TMenuItem
     102        Action = Core.AImageGradient
     103      end
    87104    end
    88105  end

  • trunk/Forms/UFormMain.pas

    r7 r10  
    77uses
    88  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
    9   ExtCtrls, ComCtrls;
     9  ExtCtrls, ComCtrls, types;
    1010
    1111type
    … …  
    2323    MenuItem17: TMenuItem;
    2424    MenuItem18: TMenuItem;
     25    MenuItem19: TMenuItem;
    2526    MenuItemRecentFiles: TMenuItem;
    2627    MenuItem15: TMenuItem;
    … …  
    3738    StatusBar1: TStatusBar;
    3839    Timer1: TTimer;
     40    procedure FormActivate(Sender: TObject);
     41    procedure FormCreate(Sender: TObject);
     42    procedure FormDestroy(Sender: TObject);
     43    procedure FormShow(Sender: TObject);
     44    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
     45      Shift: TShiftState; X, Y: Integer);
     46    procedure PaintBox1MouseLeave(Sender: TObject);
     47    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
     48      Y: Integer);
     49    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
     50      Shift: TShiftState; X, Y: Integer);
     51    procedure PaintBox1MouseWheelDown(Sender: TObject; Shift: TShiftState;
     52      MousePos: TPoint; var Handled: Boolean);
     53    procedure PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
     54      MousePos: TPoint; var Handled: Boolean);
    3955    procedure PaintBox1Paint(Sender: TObject);
    4056    procedure PaintBox1Resize(Sender: TObject);
    4157    procedure Timer1Timer(Sender: TObject);
    4258  private
    43     { private declarations }
     59    TempBitmap: TBitmap;
     60    StartMousePoint: TPoint;
     61    StartViewPoint: TPoint;
     62    MoveActive: Boolean;
     63    MousePos: TPoint;
     64    Activated: Boolean;
    4465  public
     66    procedure UpdateStatusBar;
    4567    procedure Redraw;
    4668  end;
    … …  
    6082procedure TFormMain.PaintBox1Resize(Sender: TObject);
    6183begin
    62 
     84  Redraw;
    6385end;
    6486
    6587procedure TFormMain.Timer1Timer(Sender: TObject);
    66 var
    67   Bitmap: TBitmap;
    6888begin
    6989  Timer1.Enabled := False;
    70   try
    71     Bitmap := TBitmap.Create;
    72     Bitmap.SetSize(Core.Project.Bitmap.Size.X, Core.Project.Bitmap.Size.Y);
    73     Bitmap.BeginUpdate(True);
    74     Core.Project.Bitmap.PaintToCanvas(Bitmap.Canvas);
    75     Bitmap.EndUpdate(False);
    76     PaintBox1.Canvas.Draw(0, 0, Bitmap);
    77   finally
    78     Bitmap.Free;
     90  PaintBox1.Repaint;
     91  UpdateStatusBar;
     92end;
     93
     94procedure TFormMain.UpdateStatusBar;
     95var
     96  Pos: TPoint;
     97begin
     98  with Core.Project do begin
     99    Pos := View.DestToSrcPos(MousePos);
     100    StatusBar1.Panels[0].Text := '[' + IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y) + '] Zoom:' +
     101      FloatToStr(Core.Project.View.Zoom);
    79102  end;
    80103end;
    … …  
    87110procedure TFormMain.PaintBox1Paint(Sender: TObject);
    88111begin
    89   Redraw;
     112  with Core.Project do begin
     113    TempBitmap.SetSize(View.SrcRect.Right - View.SrcRect.Left,
     114      View.SrcRect.Bottom - View.SrcRect.Top);
     115    TempBitmap.BeginUpdate(True);
     116    TempBitmap.Canvas.Brush.Color := clBlack;
     117    TempBitmap.Canvas.FillRect(0, 0, TempBitmap.Width, TempBitmap.Height);
     118    View.DestRect := Bounds(0, 0, PaintBox1.Width, PaintBox1.Height);
     119    Bitmap.PaintToCanvas(TempBitmap.Canvas, View.SrcRect);
     120    TempBitmap.EndUpdate(False);
     121    PaintBox1.Canvas.StretchDraw(View.DestRect, TempBitmap);
     122    //PaintBox1.Canvas.Draw(0, 0, TempBitmap);
     123  end;
     124end;
     125
     126procedure TFormMain.FormCreate(Sender: TObject);
     127begin
     128  TempBitmap := TBitmap.Create;
     129end;
     130
     131procedure TFormMain.FormActivate(Sender: TObject);
     132begin
     133  if not Activated then begin
     134    Activated := True;
     135    Core.Init;
     136  end;
     137end;
     138
     139procedure TFormMain.FormDestroy(Sender: TObject);
     140begin
     141  TempBitmap.Free;
     142end;
     143
     144procedure TFormMain.FormShow(Sender: TObject);
     145begin
     146end;
     147
     148procedure TFormMain.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
     149  Shift: TShiftState; X, Y: Integer);
     150begin
     151  if Button = mbLeft then begin
     152    StartMousePoint := Point(X, Y);
     153    StartViewPoint := Core.Project.View.SrcRect.TopLeft;
     154    MoveActive := True;
     155  end;
     156end;
     157
     158procedure TFormMain.PaintBox1MouseLeave(Sender: TObject);
     159begin
     160  MoveActive := False;
     161end;
     162
     163procedure TFormMain.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
     164  Y: Integer);
     165begin
     166  MousePos := Point(X, Y);
     167  if Assigned(Core.Project) then begin
     168    if MoveActive then
     169    with Core.Project do begin
     170      View.SrcRect := Bounds(Trunc(StartViewPoint.X + (StartMousePoint.X - X) / View.Zoom),
     171        Trunc(StartViewPoint.Y + (StartMousePoint.Y - Y) / View.Zoom),
     172        View.SrcRect.Right - View.SrcRect.Left,
     173        View.SrcRect.Bottom - View.SrcRect.Top);
     174      Redraw;
     175    end;
     176  end;
     177  UpdateStatusBar;
     178end;
     179
     180procedure TFormMain.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
     181  Shift: TShiftState; X, Y: Integer);
     182begin
     183  MoveActive := False;
     184end;
     185
     186procedure TFormMain.PaintBox1MouseWheelDown(Sender: TObject;
     187  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
     188begin
     189  Core.AZoomOut.Execute;
     190end;
     191
     192procedure TFormMain.PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
     193  MousePos: TPoint; var Handled: Boolean);
     194begin
     195  Core.AZoomIn.Execute;
    90196end;
    91197

  • trunk/Forms/UFormNew.pas

    r8 r10  
    6666
    6767  // Default
    68   SpinEditWidth.Value := 800;
    69   SpinEditHeight.Value := 600;
     68  SpinEditWidth.Value := 200;
     69  SpinEditHeight.Value := 100;
    7070  SpinEditDPI.Value := 72;
    7171end;

  • trunk/LibrePaint.lpi

    r9 r10  
    7171      </Item1>
    7272    </RequiredPackages>
    73     <Units Count="10">
     73    <Units Count="11">
    7474      <Unit0>
    7575        <Filename Value="LibrePaint.lpr"/>
    … …  
    9292        <Filename Value="UProject.pas"/>
    9393        <IsPartOfProject Value="True"/>
     94        <UnitName Value="UProject"/>
    9495      </Unit3>
    9596      <Unit4>
    … …  
    99100        <HasResources Value="True"/>
    100101        <ResourceBaseClass Value="Form"/>
     102        <UnitName Value="UFormNew"/>
    101103      </Unit4>
    102104      <Unit5>
    103105        <Filename Value="ColorFormats/UColorRGBA8.pas"/>
    104106        <IsPartOfProject Value="True"/>
    105         <UnitName Value="UColorRGBA8"/>
    106107      </Unit5>
    107108      <Unit6>
    … …  
    111112        <HasResources Value="True"/>
    112113        <ResourceBaseClass Value="Form"/>
     114        <UnitName Value="UFormMain"/>
    113115      </Unit6>
    114116      <Unit7>
    115117        <Filename Value="ColorFormats/UColorGray8.pas"/>
    116118        <IsPartOfProject Value="True"/>
    117         <UnitName Value="UColorGray8"/>
    118119      </Unit7>
    119120      <Unit8>
    120121        <Filename Value="ColorFormats/UColorGray1.pas"/>
    121122        <IsPartOfProject Value="True"/>
    122         <UnitName Value="UColorGray1"/>
    123123      </Unit8>
    124124      <Unit9>
    125125        <Filename Value="UMemory.pas"/>
    126126        <IsPartOfProject Value="True"/>
    127         <UnitName Value="UMemory"/>
    128127      </Unit9>
     128      <Unit10>
     129        <Filename Value="ColorFormats/UColorGray4.pas"/>
     130        <IsPartOfProject Value="True"/>
     131        <UnitName Value="UColorGray4"/>
     132      </Unit10>
    129133    </Units>
    130134  </ProjectOptions>

  • trunk/LibrePaint.lpr

    r9 r10  
    99  Interfaces, // this includes the LCL widgetset
    1010  Forms, UCore, UGraphic, UProject, UBitStream, UMemory, UFormNew, UFormMain,
    11   UColorRGBA8, UColorGray8, UColorGray1
     11  UColorRGBA8, UColorGray8, UColorGray1, UColorGray4
    1212  { you can add units after this };
    1313

  • trunk/UCore.lfm

    r7 r10  
    3939      Category = 'View'
    4040      Caption = 'Zoom all'
     41      OnExecute = AZoomAllExecute
    4142    end
    4243    object AZoomNormal: TAction
    … …  
    7677      OnExecute = AImageMirrorExecute
    7778    end
     79    object AImageGradient: TAction
     80      Category = 'Image'
     81      Caption = 'Gradient'
     82      OnExecute = AImageGradientExecute
     83    end
    7884  end
    7985  object ImageList1: TImageList

  • trunk/UCore.pas

    r9 r10  
    88  Classes, SysUtils, FileUtil, ActnList, UProject, UGraphic, Controls, Graphics;
    99
     10const
     11  ZoomFactor = 1.5;
     12
    1013type
     14  TFloatPoint = record
     15    X, Y: Double;
     16  end;
    1117
    1218  { TCore }
    1319
    1420  TCore = class(TDataModule)
     21    AImageGradient: TAction;
    1522    AImageMirror: TAction;
    1623    AImageFlip: TAction;
    … …  
    3239    procedure AImageClearExecute(Sender: TObject);
    3340    procedure AImageFlipExecute(Sender: TObject);
     41    procedure AImageGradientExecute(Sender: TObject);
    3442    procedure AImageMirrorExecute(Sender: TObject);
    3543    procedure AImageRandomExecute(Sender: TObject);
    3644    procedure AFileNewExecute(Sender: TObject);
     45    procedure AZoomAllExecute(Sender: TObject);
    3746    procedure AZoomInExecute(Sender: TObject);
    3847    procedure AZoomNormalExecute(Sender: TObject);
    … …  
    4352  public
    4453    Project: TProject;
     54    procedure Init;
    4555  end;
    4656
    … …  
    5363
    5464uses
    55   UFormNew, UFormMain, Forms, UColorRGBA8, UColorGray8, UColorGray1;
     65  UFormNew, UFormMain, Forms, UColorRGBA8, UColorGray8, UColorGray1, UColorGray4;
     66
     67function FloatPoint(AX, AY: Double): TFloatPoint;
     68begin
     69  Result.X := AX;
     70  Result.Y := AY;
     71end;
    5672
    5773{ TCore }
    … …  
    6379  ColorManager.RegisterFormat(TGColorFormatRGBA8);
    6480  ColorManager.RegisterFormat(TGColorFormatGray8);
     81  ColorManager.RegisterFormat(TGColorFormatGray4);
    6582  ColorManager.RegisterFormat(TGColorFormatGray1);
     83end;
    6684
     85procedure TCore.Init;
     86begin
    6787  // Set default
    6888  Project.Bitmap.Size := Point(200, 100);
    6989  if ColorManager.FormatCount > 0 then
    7090    Project.Bitmap.ColorFormat := ColorManager.Formats[0];
     91  Project.View.DestRect := Bounds(0, 0, FormMain.PaintBox1.Width, FormMain.PaintBox1.Height);
     92  Core.AZoomAll.Execute;
    7193end;
    7294
    … …  
    81103    Project.Bitmap.BackgroundColor.FromTColor(clBlack);
    82104    Project.Bitmap.DPI := FormNew.SpinEditDPI.Value;
    83     FormMain.Redraw;
     105    AZoomAll.Execute;;
    84106  end;
     107end;
     108
     109procedure TCore.AZoomAllExecute(Sender: TObject);
     110var
     111  Factor: TFloatPoint;
     112begin
     113  with Core.Project, View do begin
     114    Factor := FloatPoint((DestRect.Right - DestRect.Left) / Bitmap.Size.X,
     115      (DestRect.Bottom - DestRect.Top) / Bitmap.Size.Y);
     116    if Factor.X < Factor.Y then Zoom := Factor.X
     117      else Zoom := Factor.Y;
     118    Center(Rect(0, 0, Bitmap.Size.X, Bitmap.Size.Y));
     119  end;
     120  FormMain.Redraw;
    85121end;
    86122
    87123procedure TCore.AZoomInExecute(Sender: TObject);
    88124begin
    89   Project.ViewPort.Zoom := Project.ViewPort.Zoom * 1.3;
     125  Project.View.Zoom := Project.View.Zoom * ZoomFactor;
    90126  FormMain.Redraw;
    91127end;
    … …  
    93129procedure TCore.AZoomNormalExecute(Sender: TObject);
    94130begin
    95   Project.ViewPort.Zoom := 1;
     131  Project.View.Zoom := 1;
    96132  FormMain.Redraw;
    97133end;
    … …  
    99135procedure TCore.AZoomOutExecute(Sender: TObject);
    100136begin
    101   Project.ViewPort.Zoom := Project.ViewPort.Zoom / 1.3;
     137  Project.View.Zoom := Project.View.Zoom / ZoomFactor;
    102138  FormMain.Redraw;
    103139end;
    … …  
    124160end;
    125161
     162procedure TCore.AImageGradientExecute(Sender: TObject);
     163begin
     164  Core.Project.Bitmap.Gradient;
     165  FormMain.Redraw;
     166end;
     167
    126168procedure TCore.AImageMirrorExecute(Sender: TObject);
    127169begin

  • trunk/UGraphic.pas

    r9 r10  
    7272  public
    7373    function GetDataSize: Integer;
    74     procedure PaintToCanvas(Canvas: TCanvas);
     74    procedure PaintToCanvas(Canvas: TCanvas; Rect: TRect);
    7575    procedure Clear;
    7676    procedure Random;
     77    procedure Gradient;
    7778    procedure Flip;
    7879    procedure Mirror;
    … …  
    435436end;
    436437
    437 procedure TGBitmap.PaintToCanvas(Canvas: TCanvas);
     438procedure TGBitmap.PaintToCanvas(Canvas: TCanvas; Rect: TRect);
    438439var
    439440  X, Y: Integer;
    … …  
    442443  try
    443444  Canvas.Lock;
    444   for Y := 0 to Size.Y - 1 do
    445     for X := 0 to Size.X - 1 do begin
     445  for Y := Rect.Top to Rect.Bottom - 1 do
     446    for X := Rect.Left to Rect.Right - 1 do
     447    if (X >= 0) and (X < Size.X) and (Y >= 0) and (Y < Size.Y) then begin
    446448      Pixel := Pixels[X, Y];
    447       Canvas.Pixels[X, Y] := Pixel.ToTColor;
     449      Canvas.Pixels[X - Rect.Left, Y - Rect.Top] := Pixel.ToTColor;
    448450      Pixel.Free;
    449451    end;
    … …  
    475477    for X := 0 to Size.X - 1 do begin
    476478      Color.FromTColor(System.Random($ffffff));
     479      F := Cardinal(Color.Data.GetInteger);
     480
     481      Pixels[X, Y] := Color;
     482    end;
     483  Color.Free;
     484end;
     485
     486procedure TGBitmap.Gradient;
     487var
     488  X, Y: Integer;
     489  Color: TGColor;
     490  F: Cardinal;
     491  N: Integer;
     492begin
     493  Color := TGColor.Create;
     494  Color.Format := ColorFormat;
     495  for Y := 0 to Size.Y - 1 do
     496    for X := 0 to Size.X - 1 do begin
     497      if Y < Size.Y div 4 then N := $000001
     498      else if Y < Size.Y div 4 * 2 then N := $000100
     499      else if Y < Size.Y div 4 * 3 then N := $010000
     500      else N := $010101;
     501
     502      Color.FromTColor(N * (X * 255 div Size.X));
    477503      F := Cardinal(Color.Data.GetInteger);
    478504

  • trunk/UProject.pas

    r6 r10  
    1010type
    1111
    12   { TViewPort }
     12  { TView }
    1313
    14   TViewPort = class
     14  TView = class
     15  private
     16    FSrcRect: TRect;
     17    FDestRect: TRect;
     18    FZoom: Double;
     19    procedure SetDestRect(AValue: TRect);
     20    procedure SetSrcRect(AValue: TRect);
     21    procedure SetZoom(AValue: Double);
    1522  public
    16     Pos: TPoint;
    17     Zoom: Double;
    18     ViewSize: TPoint;
     23    procedure Center(Rect: TRect);
     24    constructor Create;
     25    function DestToSrcPos(Pos: TPoint): TPoint;
     26    function SrcToDestPos(Pos: TPoint): TPoint;
     27    property DestRect: TRect read FDestRect write SetDestRect;
     28    property Zoom: Double read FZoom write SetZoom;
     29    property SrcRect: TRect read FSrcRect write SetSrcRect;
    1930  end;
    2031
    … …  
    2435    FileName: string;
    2536    Bitmap: TGBitmap;
    26     ViewPort: TViewPort;
     37    View: TView;
    2738    constructor Create;
    2839    destructor Destroy; override;
    … …  
    3041
    3142implementation
     43
     44function RectEquals(A, B: TRect): Boolean;
     45begin
     46  Result := (A.Left = B.Left) and (A.Top = B.Top) and
     47    (A.Right = B.Right) and (A.Bottom = B.Bottom);
     48end;
     49
     50
     51{ TView }
     52
     53procedure TView.SetDestRect(AValue: TRect);
     54var
     55  Diff: TPoint;
     56begin
     57  if RectEquals(FDestRect, AValue) then Exit;
     58  Diff := Point(Trunc((FDestRect.Right - FDestRect.Left) / FZoom -
     59    (AValue.Right - AValue.Left) / FZoom) div 2,
     60    Trunc((FDestRect.Bottom - FDestRect.Top) / FZoom -
     61    (AValue.Bottom - AValue.Top) / FZoom) div 2);
     62  FDestRect := AValue;
     63  SrcRect := Bounds(FSrcRect.Left + Diff.X, FSrcRect.Top + Diff.Y,
     64    Trunc((FDestRect.Right - FDestRect.Left) / FZoom),
     65    Trunc((FDestRect.Bottom - FDestRect.Top) / FZoom));
     66end;
     67
     68procedure TView.SetSrcRect(AValue: TRect);
     69begin
     70  if RectEquals(FSrcRect, AValue) then Exit;
     71  FSrcRect := AValue;
     72end;
     73
     74procedure TView.SetZoom(AValue: Double);
     75const
     76  ZoomMin = 1/10000;
     77  ZoomMax = 10000;
     78begin
     79  if FZoom = AValue then Exit;
     80  if (FZoom > ZoomMax) or (FZoom < ZoomMin) then Exit;
     81  FZoom := AValue;
     82  FSrcRect := Bounds(Trunc(FSrcRect.Left + (FSrcRect.Right - FSrcRect.Left) div 2 -
     83    (DestRect.Right - DestRect.Left) / FZoom / 2),
     84    Trunc(FSrcRect.Top + (FSrcRect.Bottom - FSrcRect.Top) div 2 -
     85    (DestRect.Bottom - DestRect.Top) / FZoom / 2),
     86    Trunc((DestRect.Right - DestRect.Left) / FZoom),
     87    Trunc((DestRect.Bottom - DestRect.Top) / FZoom));
     88end;
     89
     90procedure TView.Center(Rect: TRect);
     91begin
     92  FSrcRect := Bounds(Rect.Left + (Rect.Right - Rect.Left) div 2 - (FSrcRect.Right - FSrcRect.Left) div 2,
     93    Rect.Top + (Rect.Bottom - Rect.Top) div 2 - (FSrcRect.Bottom - FSrcRect.Top) div 2,
     94    FSrcRect.Right - FSrcRect.Left,
     95    FSrcRect.Bottom - FSrcRect.Top);
     96end;
     97
     98constructor TView.Create;
     99begin
     100  FZoom := 1;
     101end;
     102
     103function TView.DestToSrcPos(Pos: TPoint): TPoint;
     104begin
     105  Result := Point(Trunc(Pos.X / FZoom + FSrcRect.Left),
     106    Trunc(Pos.Y / FZoom + FSrcRect.Top));
     107end;
     108
     109function TView.SrcToDestPos(Pos: TPoint): TPoint;
     110begin
     111  Result := Point(Trunc((Pos.X - FSrcRect.Left) * FZoom),
     112    Trunc((Pos.Y - FSrcRect.Top) * FZoom));
     113end;
    32114
    33115
    … …  
    37119begin
    38120  Bitmap := TGBitmap.Create;
    39   ViewPort := TViewPort.Create;
     121  View := TView.Create;
    40122end;
    41123
    42124destructor TProject.Destroy;
    43125begin
    44   ViewPort.Free;
     126  View.Free;
    45127  Bitmap.Free;
    46128  inherited Destroy;
Note: See TracChangeset for help on using the changeset viewer.