Changeset 7


Ignore:
Timestamp:
Sep 19, 2014, 9:25:56 AM (10 years ago)
Author:
chronos
Message:
  • Added: Mono image color format. Pixels/channels with lower size then byte are not supported yet.
  • Added: Slow image flip and mirror operation.
Location:
trunk
Files:
1 added
9 edited

Legend:

Unmodified
Added
Removed

  • trunk/ColorFormats/UColorGray8.pas

    r5 r7  
    1515    function GetBitDepth: Integer; override;
    1616    function GetName: string; override;
    17     function GetChannelBytePos(Channel: TGColorChannel): Integer; override;
     17    function GetChannelBitPos(Channel: TGColorChannel): Integer; override;
    1818    function GetChannelBitWidth(Channel: TGColorChannel): Integer; override;
    1919    function ColorToTColor(Color: TGColor): TColor; override;
    … …  
    4141end;
    4242
    43 function TGColorFormatGray8.GetChannelBytePos(Channel: TGColorChannel): Integer;
     43function TGColorFormatGray8.GetChannelBitPos(Channel: TGColorChannel): Integer;
    4444begin
    4545  case Channel of
    … …  
    5858function TGColorFormatGray8.ColorToTColor(Color: TGColor): TColor;
    5959begin
    60   Result := $010101 * PByte(Color.Data + GetChannelBytePos(ccGray))^;
     60  Result := $010101 * PByte(Color.Data + (GetChannelBitPos(ccGray) shr 3))^;
    6161end;
    6262
    6363procedure TGColorFormatGray8.ColorFromTColor(GColor: TGColor; Color: TColor);
    6464begin
    65   PByte(GColor.Data + GetChannelBytePos(ccGray))^ := ((Color and $ff) +
     65  PByte(GColor.Data + (GetChannelBitPos(ccGray) shr 3))^ := ((Color and $ff) +
    6666  ((Color shr 8) and $ff) +
    6767  ((Color shr 16) and $ff)) div 3;

  • trunk/ColorFormats/UColorRGBA8.pas

    r4 r7  
    1515    function GetBitDepth: Integer; override;
    1616    function GetName: string; override;
    17     function GetChannelBytePos(Channel: TGColorChannel): Integer; override;
     17    function GetChannelBitPos(Channel: TGColorChannel): Integer; override;
    1818    function GetChannelBitWidth(Channel: TGColorChannel): Integer; override;
    1919    function ColorToTColor(Color: TGColor): TColor; override;
    … …  
    4242end;
    4343
    44 function TGColorFormatRGBA8.GetChannelBytePos(Channel: TGColorChannel): Integer;
     44function TGColorFormatRGBA8.GetChannelBitPos(Channel: TGColorChannel): Integer;
    4545begin
    4646  case Channel of
    4747    ccRed: Result := 0;
    48     ccGreen: Result := 1;
    49     ccBlue: Result := 2;
    50     ccOpacity: Result := 3;
     48    ccGreen: Result := 8;
     49    ccBlue: Result := 16;
     50    ccOpacity: Result := 24;
    5151    else raise Exception.Create('Unsupported color channel');
    5252  end;
    … …  
    6262function TGColorFormatRGBA8.ColorToTColor(Color: TGColor): TColor;
    6363begin
    64   Result := PByte(Color.Data + GetChannelBytePos(ccRed))^ or
    65     (PByte(Color.Data + GetChannelBytePos(ccGreen))^ shl 8) or
    66     (PByte(Color.Data + GetChannelBytePos(ccBlue))^ shl 16);
     64  Result := PByte(Color.Data + (GetChannelBitPos(ccRed) shr 3))^ or
     65    (PByte(Color.Data + (GetChannelBitPos(ccGreen) shr 3))^ shl 8) or
     66    (PByte(Color.Data + (GetChannelBitPos(ccBlue) shr 3))^ shl 16);
    6767end;
    6868
    6969procedure TGColorFormatRGBA8.ColorFromTColor(GColor: TGColor; Color: TColor);
    7070begin
    71   PByte(GColor.Data + GetChannelBytePos(ccRed))^ := Color and $ff;
    72   PByte(GColor.Data + GetChannelBytePos(ccGreen))^ := (Color shr 8) and $ff;
    73   PByte(GColor.Data + GetChannelBytePos(ccBlue))^ := (Color shr 16) and $ff;
     71  PByte(GColor.Data + (GetChannelBitPos(ccRed) shr 3))^ := Color and $ff;
     72  PByte(GColor.Data + (GetChannelBitPos(ccGreen) shr 3))^ := (Color shr 8) and $ff;
     73  PByte(GColor.Data + (GetChannelBitPos(ccBlue) shr 3))^ := (Color shr 16) and $ff;
    7474end;
    7575

  • trunk/Forms/UFormMain.lfm

    r6 r7  
    55  Width = 920
    66  Caption = 'LibrePaint'
    7   ClientHeight = 611
     7  ClientHeight = 614
    88  ClientWidth = 920
    99  Menu = MainMenu1
    … …  
    1111  object PaintBox1: TPaintBox
    1212    Left = 0
    13     Height = 582
     13    Height = 588
    1414    Top = 0
    1515    Width = 920
    … …  
    2020  object StatusBar1: TStatusBar
    2121    Left = 0
    22     Height = 29
    23     Top = 582
     22    Height = 26
     23    Top = 588
    2424    Width = 920
    2525    Panels = <>
    … …  
    7676        Action = Core.AImageClear
    7777      end
     78      object MenuItem14: TMenuItem
     79        Action = Core.AImageRandom
     80      end
     81      object MenuItem17: TMenuItem
     82        Action = Core.AImageMirror
     83      end
     84      object MenuItem18: TMenuItem
     85        Action = Core.AImageFlip
     86      end
    7887    end
    7988  end

  • trunk/Forms/UFormMain.pas

    r6 r7  
    2020    MenuItem12: TMenuItem;
    2121    MenuItem13: TMenuItem;
     22    MenuItem14: TMenuItem;
     23    MenuItem17: TMenuItem;
     24    MenuItem18: TMenuItem;
    2225    MenuItemRecentFiles: TMenuItem;
    2326    MenuItem15: TMenuItem;

  • trunk/LibrePaint.lpi

    r6 r7  
    7171      </Item1>
    7272    </RequiredPackages>
    73     <Units Count="7">
     73    <Units Count="9">
    7474      <Unit0>
    7575        <Filename Value="LibrePaint.lpr"/>
    … …  
    9292        <Filename Value="UProject.pas"/>
    9393        <IsPartOfProject Value="True"/>
    94         <UnitName Value="UProject"/>
    9594      </Unit3>
    9695      <Unit4>
    … …  
    10099        <HasResources Value="True"/>
    101100        <ResourceBaseClass Value="Form"/>
    102         <UnitName Value="UFormNew"/>
    103101      </Unit4>
    104102      <Unit5>
    … …  
    115113        <UnitName Value="UFormMain"/>
    116114      </Unit6>
     115      <Unit7>
     116        <Filename Value="ColorFormats/UColorGray8.pas"/>
     117        <IsPartOfProject Value="True"/>
     118        <UnitName Value="UColorGray8"/>
     119      </Unit7>
     120      <Unit8>
     121        <Filename Value="ColorFormats/UColorGray1.pas"/>
     122        <IsPartOfProject Value="True"/>
     123        <UnitName Value="UColorGray1"/>
     124      </Unit8>
    117125    </Units>
    118126  </ProjectOptions>
    … …  
    143151        <StackChecks Value="True"/>
    144152      </Checks>
    145       <VerifyObjMethodCallValidity Value="True"/>
    146153    </CodeGeneration>
    147154    <Linking>

  • trunk/LibrePaint.lpr

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

  • trunk/UCore.lfm

    r6 r7  
    2020    end
    2121    object AImageClear: TAction
     22      Category = 'Image'
    2223      Caption = 'Clear'
    2324      OnExecute = AImageClearExecute
    … …  
    6061      Caption = 'Save as...'
    6162    end
     63    object AImageRandom: TAction
     64      Category = 'Image'
     65      Caption = 'Random'
     66      OnExecute = AImageRandomExecute
     67    end
     68    object AImageFlip: TAction
     69      Category = 'Image'
     70      Caption = 'Flip'
     71      OnExecute = AImageFlipExecute
     72    end
     73    object AImageMirror: TAction
     74      Category = 'Image'
     75      Caption = 'Mirror'
     76      OnExecute = AImageMirrorExecute
     77    end
    6278  end
    6379  object ImageList1: TImageList

  • trunk/UCore.pas

    r6 r7  
    1313
    1414  TCore = class(TDataModule)
     15    AImageMirror: TAction;
     16    AImageFlip: TAction;
     17    AImageRandom: TAction;
    1518    AFileSaveAs: TAction;
    1619    AFileSave: TAction;
    … …  
    2124    AZoomIn: TAction;
    2225    AZoomOut: TAction;
    23     AImageRandom: TAction;
    2426    AImageClear: TAction;
    2527    AExit: TAction;
    … …  
    2931    procedure AExitExecute(Sender: TObject);
    3032    procedure AImageClearExecute(Sender: TObject);
     33    procedure AImageFlipExecute(Sender: TObject);
     34    procedure AImageMirrorExecute(Sender: TObject);
    3135    procedure AImageRandomExecute(Sender: TObject);
    3236    procedure AFileNewExecute(Sender: TObject);
    … …  
    4953
    5054uses
    51   UFormNew, UFormMain, Forms, UColorRGBA8, UColorGray8;
     55  UFormNew, UFormMain, Forms, UColorRGBA8, UColorGray8, UColorGray1;
    5256
    5357{ TCore }
    … …  
    5963  ColorManager.RegisterFormat(TGColorFormatRGBA8);
    6064  ColorManager.RegisterFormat(TGColorFormatGray8);
     65  ColorManager.RegisterFormat(TGColorFormatGray1);
    6166
    6267  // Set default
    … …  
    112117end;
    113118
     119procedure TCore.AImageFlipExecute(Sender: TObject);
     120begin
     121  Project.Bitmap.Flip;
     122  FormMain.Redraw;
     123end;
     124
     125procedure TCore.AImageMirrorExecute(Sender: TObject);
     126begin
     127  Project.Bitmap.Mirror;
     128  FormMain.Redraw;
     129end;
     130
    114131procedure TCore.AImageRandomExecute(Sender: TObject);
    115132begin

  • trunk/UGraphic.pas

    r5 r7  
    2222    function GetPixelSize: Integer; virtual;
    2323    function GetName: string; virtual;
    24     function GetChannelBytePos(Channel: TGColorChannel): Integer; virtual;
     24    function GetChannelBitPos(Channel: TGColorChannel): Integer; virtual;
    2525    function GetChannelBitWidth(Channel: TGColorChannel): Integer; virtual;
    2626    function ChannelUsed(Channel: TGColorChannel): Boolean;
    … …  
    7575    procedure Clear;
    7676    procedure Random;
     77    procedure Flip;
     78    procedure Mirror;
    7779    constructor Create; virtual;
    7880    destructor Destroy; override;
    … …  
    242244end;
    243245
    244 function TGColorFormat.GetChannelBytePos(Channel: TGColorChannel): Integer;
     246function TGColorFormat.GetChannelBitPos(Channel: TGColorChannel): Integer;
    245247begin
    246248
    … …  
    437439end;
    438440
     441procedure TGBitmap.Flip;
     442var
     443  X, Y: Integer;
     444  Color: TGColor;
     445begin
     446  for Y := 0 to Size.Y div 2 - 1 do
     447    for X := 0 to Size.X - 1 do begin
     448      Color := Pixels[X, Y];
     449      Pixels[X, Y] := Pixels[X, Size.Y - 1 - Y];
     450      Pixels[X, Size.Y - 1 - Y] := Color;
     451      Color.Free;
     452    end;
     453end;
     454
     455procedure TGBitmap.Mirror;
     456var
     457  X, Y: Integer;
     458  Color: TGColor;
     459begin
     460  for Y := 0 to Size.Y - 1 do
     461    for X := 0 to Size.X div 2 - 1 do begin
     462      Color := Pixels[X, Y];
     463      Pixels[X, Y] := Pixels[Size.X - 1 - X, Y];
     464      Pixels[Size.X - 1 - X, Y] := Color;
     465      Color.Free;
     466    end;
     467end;
     468
    439469constructor TGBitmap.Create;
    440470begin
Note: See TracChangeset for help on using the changeset viewer.