home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 September / Chip_2002-09_cd1.bin / zkuste / delphi / kompon / d6 / YPPARSER.ZIP / Components / PicBldr.pas < prev   
Pascal/Delphi Source File  |  2002-06-14  |  10KB  |  299 lines
  1. {********************************************************}
  2. {                                                        }
  3. {                     TPicBldr                           }
  4. {             IMPORTANT-READ CAREFULLY:                  }
  5. {                                                        }
  6. {    This End-User License Agreement is a legal          }
  7. {    agreement between you (either an individual         }
  8. {    or a single entity) and Pisarev Yuriy for           }
  9. {    the software product identified above, which        }
  10. {    includes computer software and may include          }
  11. {    associated media, printed materials, and "online"   }
  12. {    or electronic documentation ("SOFTWARE PRODUCT").   }
  13. {    By installing, copying, or otherwise using the      }
  14. {    SOFTWARE PRODUCT, you agree to be bound by the      }
  15. {    terms of this LICENSE AGREEMENT.                    }
  16. {                                                        }
  17. {    If you do not agree to the terms of this            }
  18. {    LICENSE AGREEMENT, do not install or use            }
  19. {    the SOFTWARE PRODUCT.                               }
  20. {                                                        }
  21. {    License conditions                                  }
  22. {                                                        }
  23. {    No part of the software or the manual may be        }
  24. {    multiplied, disseminated or processed in any        }
  25. {    way without the written consent of Pisarev          }
  26. {    Yuriy. Violations of these conditions will be       }
  27. {    prosecuted in every case.                           }
  28. {                                                        }
  29. {    The use of the software is done at your own         }
  30. {    risk. The manufacturer and developer accepts        }
  31. {    no liability for any damages, either as direct      }
  32. {    or indirect consequence of the use of this          }
  33. {    product or software.                                }
  34. {                                                        }
  35. {    Only observance of these conditions allows you      }
  36. {    to use the hardware and software in your computer   }
  37. {    system.                                             }
  38. {                                                        }
  39. {    All rights reserved.                                }
  40. {    Copyright 2002 Pisarev Yuriy                        }
  41. {                                                        }
  42. {                 yuriy_mbox@hotmail.com                 }
  43. {                                                        }
  44. {********************************************************}
  45.  
  46. unit PicBldr;
  47.  
  48. interface
  49.  
  50. uses
  51.   Windows, Messages, SysUtils, Classes, Controls, Graphics, DataEditor;
  52.  
  53. type
  54.   TScripts = array of TScript;
  55.   TConstrunctEvent = procedure(Sender: TObject; Done: Integer) of object;
  56.   TPicBldr = class(TGraphicControl)
  57.   private
  58.     FShowText: Boolean;
  59.     FYValueID: Integer;
  60.     FXValueID: Integer;
  61.     FIndexID: Integer;
  62.     FCurrYValue: Integer;
  63.     FCurrXValue: Integer;
  64.     FPictureSize: Integer;
  65.     FCurrIndex: Integer;
  66.     FFileName: string;
  67.     FPicture: TBitmap;
  68.     FOnConstructing: TConstrunctEvent;
  69.     FDataEditor: TDataEditor;
  70.     FOnConstruct: TNotifyEvent;
  71.     FScripts: TScripts;
  72.     FLines: TStrings;
  73.     procedure SetLines(const Value: TStrings);
  74.     function NumFunction(FunctionID: Integer; TypeID: Integer;
  75.       var Value1: Double; Value2, Value3: Double): Boolean;
  76.   protected
  77.     procedure Paint; override;
  78.     property CurrXValue: Integer read FCurrXValue write FCurrXValue;
  79.     property CurrYValue: Integer read FCurrYValue write FCurrYValue;
  80.     property CurrIndex: Integer read FCurrIndex write FCurrIndex;
  81.     property DataEditor: TDataEditor read FDataEditor write FDataEditor;
  82.     property IndexID: Integer read FIndexID write FIndexID;
  83.     property Scripts: TScripts read FScripts write FScripts;
  84.     property XValueID: Integer read FXValueID write FXValueID;
  85.     property YValueID: Integer read FYValueID write FYValueID;
  86.   public
  87.     constructor Create(AOwner: TComponent); override;
  88.     destructor Destroy; override;
  89.     procedure Draw; virtual;
  90.     procedure LoadFromFile(const FileName: string); virtual;
  91.     procedure ClearScripts; virtual;
  92.     procedure CalcScripts; virtual;
  93.     procedure Construct; virtual;
  94.     property Picture: TBitmap read FPicture write FPicture;
  95.     property PictureSize: Integer read FPictureSize write FPictureSize;
  96.   published
  97.     property Align;
  98.     property Anchors;
  99.     property Color;
  100.     property Constraints;
  101.     property Cursor;
  102.     property Lines: TStrings read FLines write SetLines;
  103.     property DragCursor;
  104.     property DragKind;
  105.     property DragMode;
  106.     property Enabled;
  107.     property FileName: string read FFileName write FFileName;
  108.     property Font;
  109.     property Height;
  110.     property ParentColor;
  111.     property ParentFont;
  112.     property ParentShowHint;
  113.     property PopupMenu;
  114.     property ShowHint;
  115.     property ShowText: Boolean read FShowText write FShowText;
  116.     property Visible;
  117.     property Width;
  118.     property OnClick;
  119.     property OnConstruct: TNotifyEvent read FOnConstruct write FOnConstruct;
  120.     property OnConstructing: TConstrunctEvent read FOnConstructing
  121.       write FOnConstructing;
  122.     property OnContextPopup;
  123.     property OnDblClick;
  124.     property OnDragDrop;
  125.     property OnDragOver;
  126.     property OnEndDock;
  127.     property OnEndDrag;
  128.     property OnMouseDown;
  129.     property OnMouseMove;
  130.     property OnMouseUp;
  131.     property OnStartDock;
  132.     property OnStartDrag;
  133.   end;
  134.  
  135. const
  136.   ByteCounts: array [pf1Bit..pf32Bit] of Byte = (1, 1, 1, 2, 2, 3, 4);
  137.  
  138. procedure Register;
  139.  
  140. implementation
  141.  
  142. procedure Register;
  143. begin
  144.   RegisterComponents('Samples', [TPicBldr]);
  145. end;
  146.  
  147. { TPicBldr }
  148.  
  149. procedure TPicBldr.CalcScripts;
  150. var
  151.   I, J: Integer;
  152.   NewLines: TStringList;
  153. begin
  154.   ClearScripts;
  155.   NewLines := TStringList.Create;
  156.   try
  157.     for I := 0 to FLines.Count - 1 do begin
  158.       J := Length(FScripts);
  159.       SetLength(FScripts, J + 1);
  160.       try
  161.         with FDataEditor do begin
  162.           StringToNumScript(FLines[I], FScripts[J]);
  163.           ExecuteNumScript(FScripts[J]);
  164.         end;
  165.         NewLines.Add(FLines[I]);
  166.       except
  167.         FScripts[J] := nil;
  168.         SetLength(FScripts, J);
  169.       end;
  170.     end;
  171.     FLines.Assign(NewLines);
  172.   finally
  173.     NewLines.Free;
  174.   end;
  175. end;
  176.  
  177. procedure TPicBldr.ClearScripts;
  178. var
  179.   I: Integer;
  180. begin
  181.   for I := Low(FScripts) to High(FScripts) do FScripts[I] := nil;
  182.   FScripts := nil;
  183. end;
  184.  
  185. procedure TPicBldr.Construct;
  186. var
  187.   I, J, Index1, Index2, Index3, ScriptsCount: Integer;
  188.   Size: TSize;
  189.   P: Pointer;
  190. begin
  191.   ScriptsCount := Length(FScripts);
  192.   if ScriptsCount < ByteCounts[pf24bit] then Exit;
  193.   with FPicture do begin
  194.     PixelFormat := pf24bit;
  195.     Width := ClientWidth - 30;
  196.     Height := ClientHeight - 30;
  197.     Size.cx := Width * ByteCounts[pf24bit];
  198.     Size.cy := Height - 1;
  199.   end;
  200.   FPictureSize := Size.cx * (Size.cy div ByteCounts[pf24bit]);
  201.   if Assigned(FOnConstruct) then FOnConstruct(Self);
  202.   Index1 := Random(ScriptsCount);
  203.   Index2 := Random(ScriptsCount);
  204.   Index3 := Random(ScriptsCount);
  205.   FCurrIndex := 0;
  206.   for I := 0 to Size.cy do begin
  207.     J := 0;
  208.     P := FPicture.ScanLine[I];
  209.     FCurrYValue := I;
  210.     while J < Size.cx do begin
  211.       FCurrXValue := J;
  212.       with FDataEditor do begin
  213.         PByte(Integer(P) + J)^ := Round(ExecuteNumScript(FScripts[Index1]));
  214.         PByte(Integer(P) + J + 1)^ := Round(ExecuteNumScript(FScripts[Index2]));
  215.         PByte(Integer(P) + J + 2)^ := Round(ExecuteNumScript(FScripts[Index3]));
  216.       end;
  217.       Inc(J, ByteCounts[pf24bit]);
  218.       Inc(FCurrIndex);
  219.       if Assigned(FOnConstructing) then FOnConstructing(Self, FCurrIndex);
  220.     end;
  221.   end;
  222.   if FShowText then with FPicture.Canvas do begin
  223.     Font.Style := [fsBold];
  224.     J := TextHeight('0');
  225.     TextOut(10, 10, Format('Red: %s', [FLines[Index3]]));
  226.     TextOut(10, 10 + J, Format('Green: %s', [FLines[Index2]]));
  227.     TextOut(10, 10 + J * 2, Format('Blue: %s', [FLines[Index1]]));
  228.   end;
  229. end;
  230.  
  231. constructor TPicBldr.Create(AOwner: TComponent);
  232. begin
  233.   inherited;
  234.   FDataEditor := TDataEditor.Create(Self);
  235.   with FDataEditor do begin
  236.     OnNumFunction := NumFunction;
  237.     RegisterNumFunction(FXValueID, 'x', False, False);
  238.     RegisterNumFunction(FYValueID, 'y', False, False);
  239.     RegisterNumFunction(FIndexID, 'index', False, False);
  240.     SortNumFunctionsData;
  241.   end;
  242.   FPicture := TBitmap.Create;
  243.   with FPicture do PixelFormat := pf24bit;
  244.   FLines := TStringList.Create;
  245.   Randomize;
  246. end;
  247.  
  248. destructor TPicBldr.Destroy;
  249. begin
  250.   ClearScripts;
  251.   FScripts := nil;
  252.   FLines.Free;
  253.   FPicture.Free;
  254.   inherited;
  255. end;
  256.  
  257. procedure TPicBldr.Draw;
  258. begin
  259.   with Canvas do begin
  260.     Brush.Color := Color;
  261.     Pen.Style := psDot;
  262.     Rectangle(10, 10, ClientWidth - 10, ClientHeight - 10);
  263.     Draw(15, 15, FPicture);
  264.   end;
  265. end;
  266.  
  267. procedure TPicBldr.LoadFromFile(const FileName: string);
  268. begin
  269.   if FileExists(FileName) then FLines.LoadFromFile(FileName);
  270.   CalcScripts;
  271. end;
  272.  
  273. function TPicBldr.NumFunction(FunctionID, TypeID: Integer;
  274.   var Value1: Double; Value2, Value3: Double): Boolean;
  275. begin
  276.   if FunctionID = FIndexID then Value1 := FCurrIndex
  277.   else if FunctionID = FXValueID then Value1 := FCurrXValue
  278.   else if FunctionID = FYValueID then Value1 := FCurrYValue
  279.   else begin
  280.     Result := True;
  281.     Exit;
  282.   end;
  283.   Result := False;
  284. end;
  285.  
  286. procedure TPicBldr.Paint;
  287. begin
  288.   inherited;
  289.   Draw;
  290. end;
  291.  
  292. procedure TPicBldr.SetLines(const Value: TStrings);
  293. begin
  294.   FLines.Assign(Value);
  295.   ClearScripts;
  296. end;
  297.  
  298. end.
  299.