unit DXFEngine; interface uses Windows,SysUtils,StdCtrls,ComCtrls,Dialogs,Classes,Graphics,math,PCDrawing, PCTypesUtils; const message_delay_ms = 1500; EOL = #13#10; const DXF_start = 0; DXF_text_def = 1; DXF_name = 2; DXF_text_prompt = 3; DXF_othername2 = 4; DXF_entity_handle = 5; DXF_line_type = 6; DXF_text_style = 7; DXF_layer_name = 8; DXF_var_name = 9; DXF_primary_X = 10; DXF_primary_Y = 20; DXF_primary_Z = 30; DXF_other_X_1 = 11; DXF_other_Y_1 = 21; DXF_other_Z_1 = 31; DXF_other_X_2 = 12; DXF_other_Y_2 = 22; DXF_other_Z_2 = 32; DXF_other_X_3 = 13; DXF_other_Y_3 = 23; DXF_other_Z_3 = 33; DXF_elevation = 38; DXF_thickness = 39; DXF_floatval = 40; DXF_floatvals1 = 41; DXF_floatvals2 = 42; DXF_floatvals3 = 43; DXF_repeat = 49; DXF_angle1 = 50; DXF_angle2 = 51; DXF_angle3 = 52; DXF_angle4 = 53; DXF_angle5 = 54; DXF_angle6 = 55; DXF_angle7 = 56; DXF_angle8 = 57; DXF_angle9 = 58; DXF_visible = 60; DXF_colornum = 62; DXF_entities_flg = 66; DXF_ent_ident = 67; DXF_view_state = 69; DXF_70Flag = 70; DXF_71Flag = 71; DXF_72Flag = 72; DXF_73Flag = 73; DXF_74Flag = 74; DXF_extrusionx = 210; DXF_extrusiony = 220; DXF_extrusionz = 230; DXF_comment = 999; DXFtoPC = 1; const max_vertices_per_polyline = 8192; // AutoCAD places a limit on this, but max_attribs = 16; // I don't know what it is... max_my_attribs = 16; type file_type = (off,geo,pslg); type polyface = record nf : array[0..3] of integer; end; pfacelist = ^facelist; facelist = array[0..0] of polyface; pintlist = ^intlist; intlist = array[0..0] of integer; pattrlist = ^attrlist; attrlist = array[0..0] of double; type Point3D = record x,y,z : double; end; Point2D = record x,y : Double; end; PPoint3D = ^Point3D; ppointlist = ^pointlist; pointlist = array[0..0] of Point3D; const origin3D : Point3D = (x:0; y:0; z:0); WCS_X : Point3D = (x:1; y:0; z:0); WCS_Y : Point3D = (x:0; y:1; z:0); WCS_Z : Point3D = (x:0; y:0; z:1); type pMatrix = ^Matrix; pM = pMatrix; Matrix = record val : array[0..3,0..3] of double; end; const identity : Matrix = (val:((1,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))); // note the addition of base and scale factor for drawing blocks type coord_convert = function(P:Point3D; OCS:pMatrix):TPoint of Object; PC_convert = function(P:Point3D; OCS:pMatrix):TDoublePoint of Object; type planar_eq = record a,b,c,d : double; end; /////////////////////////////////////////////////////////////////////////////// // DXF_Entity - abstract base class - override where neccessary // All DXF objects will become sub classes of this /////////////////////////////////////////////////////////////////////////////// type DXF_Entity = class colour : TColor; colinx : integer; OCS_WCS : pMatrix; OCS_axis : Point3D; constructor create; destructor destroy; override; procedure init_OCS_WCS_matrix(OCSaxis:Point3D); virtual; procedure update_block_links(blist:TObject); virtual; abstract; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); virtual; abstract; procedure DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); virtual; abstract; procedure setcolour_index(col:integer); virtual; procedure setcolour(col:TColor); virtual; procedure translate(T:Point3D); virtual; abstract; procedure quantize_coords(epsilon:double; mask:byte); virtual; abstract; function count_points : integer; virtual; function count_lines : integer; virtual; function count_polys_open : integer; virtual; function count_polys_closed : integer; virtual; function proper_name : string; virtual; procedure write_DXF_Point(var IO:textfile; n:integer; p:Point3D); virtual; procedure write_to_DXF(var IO:textfile; layer:string); virtual; function details : string; virtual; abstract; procedure max_min_extents(var emax,emin:Point3D); virtual; abstract; function closest_vertex_square_distance_2D(p:Point3D) : double; virtual; abstract; function closest_vertex(p:Point3D) : Point3D; virtual; abstract; function is_point_inside_object2D(p:Point3D) : boolean; virtual; function Move_point(p,newpoint:Point3D) : boolean; virtual; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);virtual; end; /////////////////////////////////////////////////////////////////////////////// // Block_ Definition - special case - not to be used like other entities // Blocks should always appear in layer '0' // I'm still not quite sure what to do with them - but here goes anyway... /////////////////////////////////////////////////////////////////////////////// type Block_ = class(DXF_Entity) name : string; basepoint : Point3D; entities : TList; constructor create(bname:string; refpoint:Point3D); destructor destroy; override; procedure update_block_links(blist:TObject); override; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; function closest_vertex_square_distance_2D(p:Point3D) : double; override; function closest_vertex(p:Point3D) : Point3D; override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Point Definition /////////////////////////////////////////////////////////////////////////////// type Point_ = class(DXF_Entity) // always WCS p1 : Point3D; constructor create(OCSaxis,p:Point3D; col:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure translate(T:Point3D); override; procedure quantize_coords(epsilon:double; mask:byte); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; function closest_vertex_square_distance_2D(p:Point3D) : double; override; function closest_vertex(p:Point3D) : Point3D; override; function Move_point(p,newpoint:Point3D) : boolean; override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Text Definition /////////////////////////////////////////////////////////////////////////////// type Text_ = class(Point_) // always OCS h : double; textstr : string; align_pt : Point3D; // alignment point hor_align : integer; // horizontal justification code constructor create(OCSaxis,p,ap:Point3D; ss:string; height:double; col,ha:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure calcText(acanvas:TCanvas; map_fn:coord_convert; OCS:pM; t:string); function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Attrib Definition /////////////////////////////////////////////////////////////////////////////// type Attrib_ = class(Text_) // always OCS tagstr : string; visible : boolean; constructor create(OCSaxis,p,ap:Point3D; ss,tag:string; flag70,flag72:integer; height:double; col:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; type patt_array = ^att_array; att_array = array[0..0] of Attrib_; /////////////////////////////////////////////////////////////////////////////// // Attdef Definition /////////////////////////////////////////////////////////////////////////////// type Attdef_ = class(Attrib_) // always OCS promptstr : string; constructor create(OCSaxis,p,ap:Point3D; ss,tag,prompt:string; flag70,flag72:integer; height:double; col:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure write_to_DXF(var IO:textfile; layer:string); override; end; /////////////////////////////////////////////////////////////////////////////// // Insert Definition (optionally contains attribs) /////////////////////////////////////////////////////////////////////////////// type Insert_ = class(Point_) // always OCS num_attribs : integer; attribs : array[0..max_attribs] of Attrib_; blockname : string; scale : Point3D; rotation : double; blockptr : Block_; // use carefully blocklist : TObject; // to cross reference the blocks constructor create(OCSaxis,p,s_f:Point3D; rot:double; col:integer; numatts:integer; atts:patt_array; block:string); destructor destroy; override; procedure init_OCS_WCS_matrix(OCSaxis:Point3D); override; procedure update_block_links(blist:TObject); override; function block : Block_; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Line Definition /////////////////////////////////////////////////////////////////////////////// type Line_ = class(Point_) // always WCS p2 : Point3D; constructor create(p_1,p_2:Point3D; col:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure translate(T:Point3D); override; procedure quantize_coords(epsilon:double; mask:byte); override; function count_points : integer; override; function count_lines : integer; override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; function closest_vertex_square_distance_2D(p:Point3D) : double; override; function closest_vertex(p:Point3D) : Point3D; override; function Move_point(p,newpoint:Point3D) : boolean; override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Circle Definition /////////////////////////////////////////////////////////////////////////////// type Circle_ = class(Point_) // always OCS radius : double; constructor create(OCSaxis,p_1:Point3D; radius_:double; col:integer); constructor create_from_polyline(ent1:DXF_Entity); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; function is_point_inside_object2D(p:Point3D) : boolean; override; procedure max_min_extents(var emax,emin:Point3D); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Arc Definition /////////////////////////////////////////////////////////////////////////////// type Arc_ = class(Circle_) // always OCS angle1,angle2 : double; constructor create(OCSaxis,p_1:Point3D; radius_,sa,ea:double; col:integer); procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; function is_point_inside_object2D(p:Point3D) : boolean; override; procedure max_min_extents(var emax,emin:Point3D); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Polyline Definition /////////////////////////////////////////////////////////////////////////////// type Polyline_ = class(DXF_Entity) // OCS/WCS depends closed : boolean; numvertices : integer; polypoints : ppointlist; numattrs : integer; attribs : array[0..max_my_attribs-1] of double; constructor create(OCSaxis:Point3D; numpoints:integer; points:ppointlist; col:integer; closed_:boolean); destructor destroy; override; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure translate(T:Point3D); override; procedure quantize_coords(epsilon:double; mask:byte); override; function count_points : integer; override; function count_lines : integer; override; function count_polys_open : integer; override; function count_polys_closed : integer; override; function details : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; procedure max_min_extents(var emax,emin:Point3D); override; function closest_vertex_square_distance_2D(p:Point3D) : double; override; function closest_vertex(p:Point3D) : Point3D; override; // some functions I use...most removed.... function Move_point(p,newpoint:Point3D) : boolean; override; function is_point_inside_object2D(p:Point3D) : boolean; override; function triangle_centre : Point3D; procedure set_attrib(i:integer; v:double); function get_attrib(i:integer) : double; procedure copy_attribs(p:Polyline_); procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Face3D_ Definition - Should be 3DFace but can't name a type starting with 3 /////////////////////////////////////////////////////////////////////////////// type Face3D_ = class(Polyline_) // always WCS constructor create(numpoints:integer; points:ppointlist; col:integer; closed_:boolean); function proper_name : string; override; // save as 3DFACE not Face3D procedure write_to_DXF(var IO:textfile; layer:string); override; end; /////////////////////////////////////////////////////////////////////////////// // Solid_ Definition /////////////////////////////////////////////////////////////////////////////// type Solid_ = class(Face3D_) // always OCS thickness : double; constructor create(OCSaxis:Point3D; numpoints:integer; points:ppointlist; col:integer; t:double); function proper_name : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; function details : string; override; end; /////////////////////////////////////////////////////////////////////////////// // Polyline_ (polygon MxN grid mesh) Definition /////////////////////////////////////////////////////////////////////////////// type Polygon_mesh_ = class(Polyline_) // always WCS ??? M,N : integer; closeM,closeN : boolean; constructor create(numpoints,Mc,Nc:integer; points:ppointlist; closebits,col:integer); function proper_name : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; function details : string; override; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Polyline_ (polyface vertex array mesh) Definition /////////////////////////////////////////////////////////////////////////////// type Polyface_mesh_ = class(Polyline_) // always WCS ??? numfaces : integer; facelist : pfacelist; constructor create(numpoints,nfaces:integer; points:ppointlist; faces:pfacelist; col:integer); destructor destroy; override; function proper_name : string; override; procedure write_to_DXF(var IO:textfile; layer:string); override; function details : string; override; procedure Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); override; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer;OCS:pM);override; end; /////////////////////////////////////////////////////////////////////////////// // Entity_List class definition // An entity list is a collection of entities (in this case all the same type) // I wanted to keep polylines & lines etc in separate lists, so the DXF_Layer // will automatically handle this. /////////////////////////////////////////////////////////////////////////////// type DXF_Layer = class; Entity_List = class private function add_at_end(entity:DXF_Entity) : boolean; function insert(entity:DXF_Entity) : boolean; public list_name : string; parent_layer : DXF_Layer; Kludge_layer : DXF_Layer; // see selection.save... entities : TList; sorted : boolean; constructor create(l_name:string); destructor destroy; override; property name : string read list_name write list_name; function add_entity_to_list(entity:DXF_Entity) : boolean; function remove_entity(ent:DXF_Entity) : boolean; procedure draw_primitives(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); procedure draw_vertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); function num_entities : integer; function count_points : integer; function count_lines : integer; function count_polys_open : integer; function count_polys_closed : integer; procedure max_min_extents(var emax,emin:Point3D); procedure setcolour(col:integer); function closest_vertex_square_distance_2D(p:Point3D; var cl:DXF_Entity) : double; function find_bounding_object(p:Point3D) : DXF_Entity; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer); end; /////////////////////////////////////////////////////////////////////////////// // DXF_layer class definition // A collection of entity lists. One for each type. /////////////////////////////////////////////////////////////////////////////// DXF_Layer = class layer_name : string; layer_colinx : integer; entity_names : TStringList; entity_lists : TList; constructor create(l_name:string); destructor destroy; override; procedure delete(aname:string; releasemem:boolean); property Colour : integer read layer_colinx write layer_colinx; property name : string read layer_name write layer_name; function add_entity_to_layer(entity:DXF_Entity) : boolean; // Add a pre filled list (save selected to file... see selected lists) procedure add_entity_list(elist:Entity_List); // utilities function num_lists : integer; procedure max_min_extents(var emax,emin:Point3D); function create_or_find_list_type(aname:string) : Entity_List; procedure ExportToPowerCad(Cad: TPCDrawing;map_fn:PC_convert;LayerNum:integer); end; /////////////////////////////////////////////////////////////////////////////// // DXF_Object class definition // A Collection of DXF_Layers - eg a whole DXF file. /////////////////////////////////////////////////////////////////////////////// type DXF_Object = class DXF_name : string; layer_lists : TList; emax : Point3D; emin : Point3D; PCWh : Double; PCWw : Double; CadHeight : Double; CadWidth : Double; // Create an empty object constructor create(aname:string); // Create an object and load from file constructor create_from_file(aname:string; skipped:Tstrings); destructor destroy; override; procedure save_to_file(aname:string); property name : string read DXF_name write DXF_name; function num_layers : integer; // add an empty layer function new_layer(aname:string; DUPs_OK:boolean) : DXF_Layer; // add a pre-filled layer function add_layer(layer:DXF_Layer) : boolean; // return the layer with a given name function layer(aname:string) : DXF_Layer; // add an entity to a named layer function add_entity_to_layer(entity:DXF_Entity; aname:string) : boolean; // return layer and create if neccessary function create_or_find_layer(aname:string) : DXF_Layer; // Add a second DXF file to this one function merge_files(DXF_:DXF_Object) : boolean; // Useful ones procedure remove_empty_layers_and_lists; procedure copy_to_strings(ts:TStrings); function get_min_extent : Point3D; function get_max_extent : Point3D; // update the extents (not really needed) procedure max_min_extents(var emax,emin:Point3D); procedure ExportToPowerCad(Cad: TPCDrawing;Layered,IncVertex: Boolean); function GetPCPoint(P:Point3D; OCS:pMatrix): TDoublePoint; end; /////////////////////////////////////////////////////////////////////////////// // Selection_lists class definition // A collection of entity lists. Used by mouse selection routines /////////////////////////////////////////////////////////////////////////////// type selection_lists = class entity_lists : TList; constructor create; destructor destroy; override; procedure save_to_DXF_file(aname:string); function find_closest_2D_point(p:Point3D; var ent:DXF_Entity) : Point3D; function is_inside_object(p:Point3D; var ent:DXF_Entity) : Point3D; end; /////////////////////////////////////////////////////////////////////////////// // DXF exceptions will be this type /////////////////////////////////////////////////////////////////////////////// type DXF_exception = class(Exception); /////////////////////////////////////////////////////////////////////////////// // Default AutoCad layer colours (1..7) - (8..user defined) /////////////////////////////////////////////////////////////////////////////// const BYLAYER = 256; const def_cols = 12; DXF_Layer_Colours : array[0..def_cols] of TColor = (clBlack, // zero - not used clRed, clYellow, clLime, clAqua, clBlue, clPurple, {clWhite}clBlack, clOlive, clFuchsia,clTeal, clGray, clDkGray); var PCVertexOk : Boolean; /////////////////////////////////////////////////////////////////////////////// // General point 3D stuff /////////////////////////////////////////////////////////////////////////////// function aPoint3D(a,b,c:double) : Point3D; function p1_eq_p2_3D(p1,p2:Point3D) : boolean; function p1_eq_p2_2D(p1,p2:Point3D) : boolean; function p1_minus_p2(p1,p2:Point3D) : Point3D; function p1_plus_p2 (p1,p2:Point3D) : Point3D; function normalize(p1:Point3D) : Point3D; function mag(p1:Point3D) : double; function dist3D(p1,p2:Point3D) : double; function dist2D(p1,p2:Point3D) : double; function sq_dist3D(p1,p2:Point3D) : double; function sq_dist2D(p1,p2:Point3D) : double; function sq_mag3D(p1:Point3D) : double; function p1_x_n(p1:Point3D; n:double) : Point3D; function set_accuracy(factor:double; p:Point3D) : Point3D; /////////////////////////////////////////////////////////////////////////////// // Vector 3D stuff /////////////////////////////////////////////////////////////////////////////// function dot(p1,p2:Point3D) : double; function cross(p1,p2:Point3D) : Point3D; function angle(p1,p2,p3:Point3D; do_3D:boolean) : double; /////////////////////////////////////////////////////////////////////////////// // Rotations for Insert/Block drawing /////////////////////////////////////////////////////////////////////////////// function XRotateMatrix(cos_a,sin_a:double) : Matrix; function YRotateMatrix(cos_a,sin_a:double) : Matrix; function ZRotateMatrix(cos_a,sin_a:double) : Matrix; function ScaleMatrix(p:Point3D) : Matrix; function TranslateMatrix(p:Point3D) : Matrix; function MatrixMultiply(matrix1,matrix2:Matrix) : Matrix; function CreateTransformation(Ax,Ay,Az:Point3D) : Matrix; function TransformPoint(TM:Matrix; p:Point3D) : Point3D; function update_transformations(OCS_WCS,OCS:pMatrix) : pMatrix; function RotationAxis(A:Point3D; angle:double) : Matrix; /////////////////////////////////////////////////////////////////////////////// // Bounds /////////////////////////////////////////////////////////////////////////////// procedure max_bound(var bounds:Point3D; point:Point3D); procedure min_bound(var bounds:Point3D; point:Point3D); function dmin(a,b:double) : double; function dmax(a,b:double) : double; function imin(a,b:integer) : integer; function imax(a,b:integer) : integer; /////////////////////////////////////////////////////////////////////////////// // Memory /////////////////////////////////////////////////////////////////////////////// function allocate_points(n:integer) : ppointlist; procedure deallocate_points(var pts:ppointlist; n:integer); function allocate_matrix : pMatrix; procedure deallocate_matrix(var m:pMatrix); /////////////////////////////////////////////////////////////////////////////// // String /////////////////////////////////////////////////////////////////////////////// function float_out(f:double) : string; function Point3DToStr(p:Point3D) : string; function BoolToStr(b:boolean) : string; /////////////////////////////////////////////////////////////////////////////// // DXF_Writer class definition /////////////////////////////////////////////////////////////////////////////// type DXF_Writer = class private IO_Chan : Text; public // Extents in (x,y) of the dataset min_extents : Point3D; max_extents : Point3D; DXF_Layers : TList; // Constructors and destructors Constructor create(aname:string; data_list:TList); Destructor destroy; override; procedure write_file; // Header section function write_header : boolean; // Tables section function write_tables : boolean; function write_layer_information : boolean; function write_vport_information : boolean; // BLocks section function write_blocks : boolean; // Entities section function write_entities : boolean; end; // DXF File write exceptions will be this type type DXF_write_exception = class(Exception); /////////////////////////////////////////////////////////////////////////////// // DXF_Reader class definition /////////////////////////////////////////////////////////////////////////////// Const MaxSizeOfBuf = 4096; type tCharArray = array [0..MaxSizeOfBuf-1] of char; type abstract_entity = class; DXF_Reader = class private // used when reading data from the file IO_chan : file; SizeOfBuf : integer; num_in_buf : integer; ii : integer; EC,fCode : integer; pBuf : ^tCharArray; Line_num : longint; fLine : shortstring; //progress : TProgressBar; // useful bits to make parsing easier... file_pos : integer; marked_pos : integer; backflag : boolean; procedure go_back_to_last(code:integer; str:shortstring); procedure mark_position; procedure goto_marked_position; // procedure go_back_to_start; function NextGroupCode: integer; function ValStr: shortstring; function ValDbl: double; function ValInt: integer; function code_and_string(var group:integer; var s:string) : boolean; function code_and_double(var group:integer; var d:double) : boolean; function read_2Dpoint(var p1:Point3D) : boolean; function skip_upto_section(name:string) : boolean; // lowest level read function function read_entity_data(ent:abstract_entity) : boolean; function read_generic(var layer:integer) : abstract_entity; // we can read most entities with this one function general_purpose_read(obj_type:TClass; var entity:DXF_Entity; var layer:integer) : boolean; // inserts/polylines need a little more complexity function read_insert(var entity:DXF_Entity; var layer:integer) : boolean; function read_polyline(var entity:DXF_Entity; var layer:integer) : boolean; // this calls the others above function read_entity(s,endstr:string; var entity:DXF_Entity; var layer:integer) : boolean; public // Extents in (x,y) of the dataset min_extents : Point3D; max_extents : Point3D; // We will read the Entities in the layers into this list DXF_Layers : TList; colour_BYLAYER : boolean; skipped : TStrings; // Constructors and destructors Constructor Create (const aName: shortstring); Destructor Destroy; override; // Header section function move_to_header_section : boolean; function read_header : boolean; function get_min_extent : Point3D; function get_max_extent : Point3D; // Blocks section function move_to_blocks_section : boolean; function read_blocks : boolean; function read_block : boolean; function block_list : Entity_List; // Tables section function move_to_tables_section : boolean; function read_tables : boolean; function read_layer_information : boolean; function read_vport_information : boolean; function layer_num(layername:string) : integer; // Entities section function move_to_entity_section : boolean; function read_entities : boolean; // These are the main routines to use function read_file : boolean; function remove_empty_layers : boolean; function release_control_of_layers : TList; procedure set_skipped_list(s:TStrings); end; /////////////////////////////////////////////////////////////////////////////// // This is a simple class used only during file reads, it should not be used // as a base for any objects. // It is to allow all entities to be read using the same basic structure // even though they all use different group codes // Add extra group codes if you need to recognize them /////////////////////////////////////////////////////////////////////////////// abstract_entity = class p1,p2,p3,p4 : Point3D; rad_hgt : double; angle1,angle2 : double; fv1,fv2,fv3 : double; thickness : double; colour : integer; flag_70,flag_71,flag_72,flag_73,flag_74 : integer; attflag : integer; namestr,tagstr,promptstr : string; layer : string; elev : double; OCS_Z : Point3D; procedure clear; end; /////////////////////////////////////////////////////////////////////////////// // DXF file read exceptions will be this type /////////////////////////////////////////////////////////////////////////////// type DXF_read_exception = class(Exception) line_number : integer; constructor create(err_msg:string; line:integer); end; /////////////////////////////////////////////////////////////////////////////// // Memory check variables /////////////////////////////////////////////////////////////////////////////// var entities_in_existence : integer; Ent_lists_in_existence : integer; layers_in_existence : integer; DXF_Obj_in_existence : integer; implementation { --------------------------------------------------------------------------- } { ------------------- DXFWriter ----------------------- } { --------------------------------------------------------------------------- } Constructor DXF_Writer.Create(aname:string; data_list:TList); begin Inherited Create; AssignFile(IO_Chan,aName); Rewrite(IO_Chan); DXF_Layers := data_list; end; destructor DXF_Writer.Destroy; begin CloseFile(IO_chan); Inherited Destroy; end; procedure DXF_Writer.write_file; begin write_header; write_tables; write_blocks; write_entities; writeln(IO_chan,0,EOL,'EOF'); end; function DXF_Writer.write_header : boolean; var lp1 : integer; begin min_extents := aPoint3D( 1E10, 1E10, 1E10); max_extents := aPoint3D(-1E10,-1E10,-1E10); writeln(IO_chan,0,EOL,'SECTION'); writeln(IO_chan,2,EOL,'HEADER'); for lp1:=0 to DXF_layers.count-1 do DXF_Layer(DXF_Layers[lp1]).max_min_extents(max_extents,min_extents); writeln(IO_chan,9 ,EOL,'$EXTMIN'); writeln(IO_chan,10,EOL,FloatToStr(min_extents.x)); writeln(IO_chan,20,EOL,FloatToStr(min_extents.y)); writeln(IO_chan,30,EOL,FloatToStr(min_extents.z)); writeln(IO_chan,9 ,EOL,'$EXTMAX'); writeln(IO_chan,10,EOL,FloatToStr(max_extents.x)); writeln(IO_chan,20,EOL,FloatToStr(max_extents.y)); writeln(IO_chan,30,EOL,FloatToStr(max_extents.z)); writeln(IO_chan,0,EOL,'ENDSEC'); end; function DXF_Writer.write_tables : boolean; begin writeln(IO_chan,0,EOL,'SECTION'); writeln(IO_chan,2,EOL,'TABLES'); write_vport_information; write_layer_information; writeln(IO_chan,0,EOL,'ENDSEC'); end; function DXF_Writer.write_layer_information : boolean; var lp1 : integer; layer : DXF_Layer; begin writeln(IO_chan,0,EOL,'TABLE'); writeln(IO_chan,2,EOL,'LAYER'); for lp1:=DXF_layers.count-1 downto 0 do begin layer := DXF_Layer(DXF_Layers[lp1]); writeln(IO_chan,0 ,EOL,'LAYER'); writeln(IO_chan,2 ,EOL,layer.name); writeln(IO_chan,62,EOL,layer.layer_colinx); end; writeln(IO_chan,0,EOL,'ENDTAB'); end; function DXF_Writer.write_vport_information : boolean; begin writeln(IO_chan,0,EOL,'TABLE'); writeln(IO_chan,2,EOL,'VPORT'); writeln(IO_chan,0,EOL,'VPORT'); writeln(IO_chan,2,EOL,'*ACTIVE'); writeln(IO_chan,41,EOL,1.0{aspect}:10:6); writeln(IO_chan,0,EOL,'ENDTAB'); end; function DXF_Writer.write_blocks : boolean; var lp1,lp2,lp3 : integer; layer : DXF_Layer; eList : Entity_List; begin writeln(IO_chan,0,EOL,'SECTION'); writeln(IO_chan,2,EOL,'BLOCKS'); // find the layer with the blocks in it (should be '0') layer := nil; for lp1:=0 to DXF_Layers.count-1 do if DXF_Layer(DXF_Layers[lp1]).name='0' then layer := DXF_Layer(DXF_Layers[lp1]); if layer<>nil then begin for lp2:=0 to layer.num_lists-1 do begin eList := Entity_List(layer.entity_lists[lp2]); if eList.name=Block_.ClassName then begin for lp3:=0 to eList.entities.Count-1 do begin DXF_Entity(eList.entities[lp3]).write_to_DXF(IO_chan,layer.name); end; end; end; end; writeln(IO_chan,0,EOL,'ENDSEC'); end; function DXF_Writer.write_entities : boolean; var lp1,lp2,lp3 : integer; layer : DXF_Layer; eList : Entity_List; begin writeln(IO_chan,0,EOL,'SECTION'); writeln(IO_chan,2,EOL,'ENTITIES'); for lp1:=0 to DXF_layers.count-1 do begin layer := DXF_Layer(DXF_Layers[lp1]); for lp2:=0 to layer.num_lists-1 do begin eList := Entity_List(layer.entity_lists[lp2]); if eList.name<>Block_.ClassName then begin for lp3:=0 to eList.entities.Count-1 do begin DXF_Entity(eList.entities[lp3]).write_to_DXF(IO_chan,layer.name); end; end; end; end; writeln(IO_chan,0,EOL,'ENDSEC'); end; /////////////////////////////////////////////////////////////////////////////// // abstract_entity implementation // used when reading vertexes - just to make sure all flags are reset // quicker than using create/destroy for each vertex. /////////////////////////////////////////////////////////////////////////////// procedure abstract_entity.clear; begin InitInstance(self); end; /////////////////////////////////////////////////////////////////////////////// // DXFReader implementation /////////////////////////////////////////////////////////////////////////////// Constructor DXF_Reader.Create (const aName: shortstring); begin Inherited Create; AssignFile(IO_chan,aName); Reset(IO_chan,1); SizeOfBuf := MaxSizeOfBuf; GetMem(pBuf,SizeOfBuf); DXF_Layers := TList.Create; colour_BYLAYER := false; Line_num := 0; backflag := false; min_extents := origin3D; max_extents := origin3D; end; destructor DXF_Reader.Destroy; var lp1 : integer; begin if (DXF_Layers<>nil) then for lp1 := 0 to DXF_Layers.count-1 do DXF_Layer(DXF_Layers[lp1]).Free; DXF_Layers.Free; CloseFile(IO_chan); FreeMem(pBuf,SizeOfBuf); Inherited Destroy; end; { --------------------------------------------------------------------------- } { Routines for fetching codes and values { --------------------------------------------------------------------------- } procedure DXF_Reader.go_back_to_start; begin Reset(IO_chan,1); num_in_buf := 0; ii := 0; end; procedure DXF_Reader.go_back_to_last(code:integer; str:shortstring); begin fCode := code; fLine := str; backflag := true; end; procedure DXF_Reader.mark_position; begin marked_pos := File_pos + ii; end; procedure DXF_Reader.goto_marked_position; begin Seek(IO_chan,marked_pos); File_pos := marked_pos; num_in_buf := 0; ii := 0; end; function DXF_Reader.NextGroupCode: integer; function GotMore: boolean; begin file_pos := FilePos(IO_chan); BlockRead(IO_chan,pBuf^,SizeOfBuf,num_in_buf); ec:=IoResult; ii:=0; If (ec=0) and (num_in_buf=0) then ec:=-1; GotMore:=(ec=0); //progress.position := progress.position+1; end{GotMore}; // Sometimes you get (download) a bad DXF file which has a couple of blank // lines in it. The commented retry code, can be used to skip blank lines, but you // should only use it as an emergency fix because you'll often find blank lines // in TEXT entities and other text strings. function GotLine: boolean; const CR=#13; LF=#10; var c: Ansichar; // label retry; begin // retry: byte(fLine[0]):=0; While (iiCR) and (c<>LF) and (length(fLine)<255) then begin inc(fLine[0]); fLine[length(fLine)]:=c end else begin // Extra code added to handle C/Unix style LF not CR/LF if (c=CR) then begin if (ii''; Val(fLine,fCode,ec); If ec<>0 then fCode:=-2 else if not GotLine then fCode:=-2; Result:=fCode; end; end {NextGroupCode}; function DXF_Reader.ValStr: shortstring; begin Result:=fLine end; function DXF_Reader.ValDbl: double; begin Val(fLine,Result,ec); If ec<>0 then raise DXF_read_exception.Create('Invalid Floating point conversion',line_num); end; function DXF_Reader.ValInt: integer; begin Val(fLine,Result,ec); If ec<>0 then raise DXF_read_exception.Create('Invalid Integer conversion',line_num); end; function DXF_Reader.code_and_string(var group:integer; var s:string) : boolean; var astr : string; begin result := true; group := NextGroupCode; if group>=0 then s := ValStr else result := false; // useful in debugging // if (group=0) then begin astr := IntToStr(group)+' '+s; alb.Items.Add(astr); end; end; function DXF_Reader.code_and_double(var group:integer; var d:double) : boolean; begin result := true; group := NextGroupCode; if group>=0 then d := Valdbl else result := false; end; // This routine is just for the $EXT(max/min) and should be used with care.... function DXF_Reader.read_2Dpoint(var p1:Point3D) : boolean; var Groupcode : integer; begin repeat Groupcode:=NextGroupCode; until (Groupcode=DXF_primary_X) or (Groupcode<0); if Groupcode<0 then begin result:=false; exit; end; p1.x := Valdbl; result := code_and_double(Groupcode,p1.y); { y next } end; function DXF_Reader.skip_upto_section(name:string) : boolean; var Group : integer; s : string; begin result := false; repeat if not code_and_string(Group,s) then break; if (Group=0) then begin if (s='SECTION') then begin if not code_and_string(Group,s) then break; if (Group=DXF_name) then begin if (s=name) then result := true else exit; end else if skipped<>nil then Skipped.Add(s); end else if skipped<>nil then Skipped.Add(s); end; until (result); end; { --------------------------------------------------------------------------- } { Header section { --------------------------------------------------------------------------- } function DXF_Reader.move_to_header_section : boolean; begin result := skip_upto_section('HEADER'); end; function DXF_Reader.read_header : boolean; var Group : integer; s : string; begin result := false; repeat if not code_and_string(Group,s) then break; if (group=9) and (s='$EXTMAX') then begin if not read_2Dpoint(max_extents) then break; end; if (group=9) and (s='$EXTMIN') then begin if not read_2Dpoint(min_extents) then break; end; if (group=9) and (s='$CECOLOR') then begin if (NextGroupCode=DXF_colornum) and (ValInt=256) then colour_BYLAYER := true; end; result := (Group=0) and (s='ENDSEC'); until result; end; function DXF_Reader.get_min_extent : Point3D; begin result := min_extents; end; function DXF_Reader.get_max_extent : Point3D; begin result := max_extents; end; { --------------------------------------------------------------------------- } { Blocks section { --------------------------------------------------------------------------- } function DXF_Reader.move_to_blocks_section : boolean; begin result := skip_upto_section('BLOCKS'); end; function DXF_Reader.read_blocks : boolean; var Group : integer; s : string; begin result := false; repeat if not code_and_string(Group,s) then break; if (Group=0) and (s='BLOCK') then begin if not read_block then break; end; result := (Group=0) and (s='ENDSEC'); until result; end; function DXF_Reader.read_block : boolean; var Groupcode : integer; s : string; ent : abstract_entity; block : Block_; layer,lp1 : integer; entity : DXF_Entity; base : Point3D; begin result := false; ent := read_generic(layer); layer := layer_num('0'); // ALL BLOCKS GOING TO LAYER 0 (makes things easier) if layer<0 then layer := DXF_Layers.Add(DXF_Layer.create('0')); if ent<>nil then begin block := Block_.create(ent.namestr,ent.p1); DXF_Layer(DXF_Layers[layer]).add_entity_to_layer(block); repeat if not code_and_string(Groupcode,s) then break; if (Groupcode=0) then begin result := read_entity(s,'ENDBLK',entity,layer); if entity<>nil then block.entities.Add(entity); end; until result; end; end; // we need to know where the blocks are stored for lookup purposes function DXF_Reader.block_list : Entity_List; var lp1,lp2 : integer; layer : DXF_Layer; begin for lp1:=0 to DXF_Layers.count -1 do begin layer := DXF_Layers[lp1]; for lp2:=0 to layer.entity_lists.count-1 do begin if Entity_List(layer.entity_lists[lp2]).name='Block_' then begin result := Entity_List(layer.entity_lists[lp2]); exit; end; end; end; end; { --------------------------------------------------------------------------- } { Tables (Layers - VPort) section { --------------------------------------------------------------------------- } function DXF_Reader.move_to_tables_section : boolean; begin result := skip_upto_section('TABLES'); end; function DXF_Reader.read_tables : boolean; var Group : integer; s : string; begin result := false; repeat if not code_and_string(Group,s) then break; if (Group=0) and (s='TABLE') then begin if not code_and_string(Group,s) then break; if (Group=DXF_name) then begin if (s='LAYER') then read_layer_information else if (s='VPORT') then read_vport_information else if skipped<>nil then Skipped.Add(s); end; end; result := (Group=0) and (s='ENDSEC'); until result; end; function DXF_Reader.read_layer_information : boolean; var Group,Lay_num : integer; s : string; begin lay_num := -1; result := false; repeat if not code_and_string(Group,s) then break; if (Group=0) then begin if (s='LAYER') then begin if not code_and_string(Group,s) then break; if (Group=DXF_name) then lay_num := DXF_Layers.Add(DXF_Layer.create(s)); end else if (s='ENDTAB') then result := true else if skipped<>nil then Skipped.Add(s); end else if (Group=DXF_colornum) and (lay_num<>-1) then DXF_Layer(DXF_Layers[lay_num]).Colour := ValInt; until result; end; // This no longer does anything ! function DXF_Reader.read_vport_information : boolean; var Group : integer; s : string; begin result := false; repeat if not code_and_string(Group,s) then break; if (Group=0) then begin if (s='VPORT') then begin if not code_and_string(Group,s) then break; if (Group=DXF_name) then begin if (s='*ACTIVE') then repeat if not code_and_string(Group,s) then break; { removed Aspectratio stuff since it never seems to make any difference and sometimes buggers everything up if (Group=DXF_floatvals1) then Aspect := ValDbl; } result := (Group=0) and (s='ENDTAB'); until (result) else if skipped<>nil then Skipped.Add(s); end; end else if skipped<>nil then Skipped.Add(s); end until (result); end; function DXF_Reader.layer_num(layername:string) : integer; var lp1 : integer; begin result := -1; for lp1:=0 to DXF_Layers.count-1 do begin if DXF_Layer(DXF_Layers[lp1]).name=layername then begin result := lp1; exit; end; end; end; { --------------------------------------------------------------------------- } { Entities section { --------------------------------------------------------------------------- } function DXF_Reader.move_to_entity_section : boolean; begin result := skip_upto_section('ENTITIES'); end; function DXF_Reader.read_entities : boolean; var Groupcode,layer : integer; s : string; entity : DXF_Entity; begin result := false; repeat try if not code_and_string(Groupcode,s) then break; if (Groupcode=0) then begin result := read_entity(s,'ENDSEC',entity,layer); // put the entity in the layer... if entity<>nil then DXF_Layer(DXF_Layers[layer]).add_entity_to_layer(entity); end; except on E:DXF_read_exception do begin if MessageBox(0,@E.message[1],'DXF read error warning',MB_OKCANCEL)=IDCANCEL then raise DXF_read_exception.Create('User aborted',-1); end; on E:Exception do Showmessage(E.Message); end; until result; end; { --------------------------------------------------------------------------- } { Entity reading code { --------------------------------------------------------------------------- } function DXF_Reader.read_entity_data(ent:abstract_entity) : boolean; var Groupcode : integer; begin ent.OCS_Z := WCS_Z; repeat Groupcode := NextGroupCode; case Groupcode of DXF_primary_X : ent.p1.x := Valdbl; DXF_primary_Y : ent.p1.y := Valdbl; DXF_primary_Z : ent.p1.z := Valdbl; DXF_other_X_1 : ent.p2.x := Valdbl; DXF_other_Y_1 : ent.p2.y := Valdbl; DXF_other_Z_1 : ent.p2.z := Valdbl; DXF_other_X_2 : ent.p3.x := Valdbl; DXF_other_Y_2 : ent.p3.y := Valdbl; DXF_other_Z_2 : ent.p3.z := Valdbl; DXF_other_X_3 : ent.p4.x := Valdbl; DXF_other_Y_3 : ent.p4.y := Valdbl; DXF_other_Z_3 : ent.p4.z := Valdbl; DXF_floatval : ent.rad_hgt := Valdbl; DXF_floatvals1 : ent.fv1 := Valdbl; DXF_floatvals2 : ent.fv2 := Valdbl; DXF_floatvals3 : ent.fv3 := Valdbl; DXF_angle1 : ent.angle1 := Valdbl; DXF_angle2 : ent.angle2 := Valdbl; DXF_thickness : ent.thickness := Valdbl; DXF_elevation : ent.elev := Valdbl; DXF_70Flag : ent.flag_70 := ValInt; DXF_71Flag : ent.flag_71 := ValInt; DXF_72Flag : ent.flag_72 := ValInt; DXF_73Flag : ent.flag_73 := ValInt; DXF_74Flag : ent.flag_74 := ValInt; DXF_colornum : ent.colour := ValInt; DXF_entities_flg : ent.attflag := ValInt; DXF_layer_name : ent.layer := ValStr; DXF_name : ent.namestr := ValStr; DXF_text_def : ent.tagstr := ValStr; DXF_text_prompt : ent.promptstr := ValStr; DXF_extrusionx : ent.OCS_Z.x := Valdbl; DXF_extrusiony : ent.OCS_Z.y := Valdbl; DXF_extrusionz : ent.OCS_Z.z := Valdbl; end; until (Groupcode<=0); // end or fault; if Groupcode<0 then begin result:=false; exit; end; // we need to put the code=0, and valstr back, so the next entity starts // with the zero when neccessary go_back_to_last(Groupcode,fline); ent.OCS_Z := normalize(ent.OCS_Z); // for safety result := true; end; function DXF_Reader.read_generic(var layer:integer) : abstract_entity; var ent : abstract_entity; s : string; begin result := nil; ent := abstract_entity.create; // set everything to zero EVERY time if read_entity_data(ent) then begin layer := layer_num(ent.layer); if layer<0 then layer := DXF_Layers.Add(DXF_Layer.create(ent.layer)); result := ent; end else ent.free; end; { These ones are straightforward, so we'll use a crafty TClass parameter } function DXF_Reader.general_purpose_read(obj_type:TClass; var entity:DXF_Entity; var layer:integer) : boolean; var ent : abstract_entity; begin entity := nil; ent := read_generic(layer); if ent<>nil then begin with ent do begin if obj_type = Point_ then entity := Point_. create(OCS_Z,p1,colour) else if obj_type = Text_ then entity := Text_. create(OCS_Z,p1,p2,tagstr,rad_hgt,colour,flag_72) else if obj_type = Line_ then entity := Line_. create(p1,p2,colour) else if obj_type = Circle_ then entity := Circle_.create(OCS_Z,p1,rad_hgt,colour) else if obj_type = Arc_ then entity := Arc_. create(OCS_Z,p1,rad_hgt,angle1,angle2,colour) // face3ds and solids can have 3 or 4 points, if 4=3, then 3 used else if obj_type = Face3D_ then begin if p1_eq_p2_3d(p3,p4) then entity := Face3D_.create(3, @p1, colour,true) else entity := Face3D_.create(4, @p1, colour,true) end else if obj_type = Solid_ then begin if p1_eq_p2_3d(p3,p4) then entity := Solid_.create(OCS_Z,3, @p1, colour,thickness) else entity := Solid_.create(OCS_Z,4, @p1, colour,thickness) end else if obj_type = Attdef_ then entity := Attdef_.create(OCS_Z,p1,p2,namestr,tagstr,promptstr,flag_70,flag_72,rad_hgt,colour) else if obj_type = Attrib_ then entity := Attrib_.create(OCS_Z,p1,p2,namestr,tagstr,flag_70,flag_72,rad_hgt,colour); end; ent.Free; result := true; end; end; { INSERTs may have ATTRIBs + BLOCKs which makes it a little more complicated } function DXF_Reader.read_insert(var entity:DXF_Entity; var layer:integer) : boolean; var ent,ent2 : abstract_entity; code,num : integer; atts : array[0..255] of Attrib_; begin result := true; entity := nil; num := 0; ent := read_generic(layer); if ent<>nil then begin if ent.attflag=1 then begin repeat result := (Nextgroupcode=0); if result and (ValStr='ATTRIB') then begin ent2 := read_generic(layer); if ent2<>nil then with ent2 do begin atts[num] := Attrib_.create(OCS_Z,p1,p2,namestr,tagstr,flag_70,flag_72,rad_hgt,colour); ent2.Free; inc(num); end else result := false; end; until (not result) or (ValStr='SEQEND'); if result then Nextgroupcode; // remove the SEQEND put back end; with ent do begin if fv1=0 then fv1 := 1; if fv2=0 then fv2 := 1; if fv3=0 then fv3 := 1; entity := Insert_.create(OCS_Z,p1,aPoint3D(fv1,fv2,fv3),angle1,colour,num,@atts[0],namestr); try Insert_(entity).update_block_links(block_list); except entity.Free; entity := nil; raise DXF_read_exception.Create('Cannot reference an undefined BLOCK'+EOL+EOL+ '(File may not have been saved with BLOCKs)'+EOL,line_num); end; end; ent.Free; end else result := false; end; // POLYLINEs have variable number of points... // Modified to accept polyface mesh variety of polyline ... // I've ignored the invisible flag for edges // Modified to accept polygon MxN grid mesh ... // It's a bit messy - you could simplify it a bit - but hey - what do you // expect from free code. function DXF_Reader.read_polyline(var entity:DXF_Entity; var layer:integer) : boolean; var ent1,ent2 : abstract_entity; vertices,lp1 : integer; faces : integer; tempvert : array[0..max_vertices_per_polyline-1] of Point3D; tempface : array[0..4095] of polyface; closed_poly : boolean; M,N,mn : integer; label vertex_overflow; begin result := false; closed_poly := false; entity := nil; ent1 := abstract_entity.create; // read initial polyline data if not read_entity_data(ent1) then begin ent1.Free; exit; end; layer := layer_num(ent1.layer); if (layer=-1) then layer := DXF_Layers.Add(DXF_Layer.create(ent1.layer)); vertices := 0; faces := 0; ent2 := abstract_entity.create; ////////////////////////////////////////// ////////////////////////////////////////// if (ent1.flag_70 and (64+16))=0 then begin // THIS IS A NORMAL POLYLINE repeat if (NextGroupCode=0) and (ValStr = 'VERTEX') then begin ent2.clear; if read_entity_data(ent2) then begin tempvert[vertices] := ent2.p1; inc(vertices); if vertices>=max_vertices_per_polyline then goto vertex_overflow; end else begin ent1.Free; ent2.Free; exit; end; // error end; until fLine='SEQEND'; // this should set result to true, because 0 SEQEND is next result := NextGroupCode=0; if ((ent1.flag_70) and 1)=1 then closed_poly := true; entity := Polyline_.create(ent1.OCS_Z,vertices,@tempvert[0],ent1.colour,closed_poly); end ////////////////////////////////////////// ////////////////////////////////////////// else if (ent1.flag_70 and 16)=16 then begin // THIS IS A POLYGON MESH - a grid of vertices joined along M & N M := ent1.flag_71; N := ent1.flag_72; mn := 0; repeat if (NextGroupCode=0) and (ValStr = 'VERTEX') then begin if read_entity_data(ent2) then begin inc(mn); if (ent2.Flag_70 and 64)=64 then begin tempvert[vertices] := ent2.p1; inc(vertices); if vertices>=max_vertices_per_polyline then goto vertex_overflow; end else begin ent1.Free; ent2.Free; exit; end; // error end else begin ent1.Free; ent2.Free; exit; end; // error end; until fLine='SEQEND'; result := NextGroupCode=0; if mn<>M*N then begin ent1.Free; ent2.Free; exit; end; // error entity := Polygon_mesh_.create(vertices,M,N,@tempvert[0],ent1.flag_70,ent1.colour); end ////////////////////////////////////////// ////////////////////////////////////////// else if (ent1.flag_70 and 64)=64 then begin // THIS IS A POLYFACE MESH - a vertex array with facets repeat if (NextGroupCode=0) and (ValStr = 'VERTEX') then begin if read_entity_data(ent2) then begin if (ent2.Flag_70 and (128+64))=(128+64) then begin // this is a normal coordinate vertex tempvert[vertices] := ent2.p1; inc(vertices); if vertices>=max_vertices_per_polyline then goto vertex_overflow; end else if (ent2.Flag_70 and (128))=(128) then begin // this is a face definition vertex // negative indices indicate invisible edges (ignored for now) tempface[faces].nf[0] := Abs(ent2.flag_71)-1; // index 1..n -> 0..n-1 tempface[faces].nf[1] := Abs(ent2.flag_72)-1; tempface[faces].nf[2] := Abs(ent2.flag_73)-1; tempface[faces].nf[3] := Abs(ent2.flag_74)-1; inc(faces); end else begin ent1.Free; ent2.Free; exit; end; // error end else begin ent1.Free; ent2.Free; exit; end; // error end; until fLine='SEQEND'; result := NextGroupCode=0; entity := Polyface_mesh_.create(vertices,faces,@tempvert[0],@tempface[0],ent1.colour); end; ////////////////////////////////////////// ////////////////////////////////////////// ent1.Free; ent2.Free; exit; // next bit only when vertices overflow vertex_overflow: ent1.Free; ent2.Free; raise DXF_read_exception.Create('Polyline contained more than '+ IntToStr(max_vertices_per_polyline)+' vertices',line_num); end; function DXF_Reader.read_entity(s,endstr:string; var entity:DXF_Entity; var layer:integer) : boolean; begin entity := nil; result := false; if (s='POINT') then begin if not general_purpose_read(Point_,entity,layer) then raise DXF_read_exception.Create('Error reading POINT entity',line_num); end else if (s='INSERT') then begin if not read_insert(entity,layer) then raise DXF_read_exception.Create('Error reading INSERT entity',line_num); end else if (s='TEXT') then begin if not general_purpose_read(Text_,entity,layer) then raise DXF_read_exception.Create('Error reading TEXT entity',line_num); end else if (s='LINE') then begin if not general_purpose_read(Line_,entity,layer) then raise DXF_read_exception.Create('Error reading LINE entity',line_num); end else if (s='POLYLINE') then begin if not read_polyline(entity,layer) then raise DXF_read_exception.Create('Error reading POLYLINE entity',line_num); end else if (s='3DFACE') then begin if not general_purpose_read(Face3D_,entity,layer) then raise DXF_read_exception.Create('Error reading 3DFACE entity',line_num); end else if (s='SOLID') then begin if not general_purpose_read(Solid_,entity,layer) then raise DXF_read_exception.Create('Error reading SOLID entity',line_num); end else if (s='CIRCLE') then begin if not general_purpose_read(Circle_,entity,layer) then raise DXF_read_exception.Create('Error reading CIRCLE entity',line_num); end else if (s='ARC') then begin if not general_purpose_read(Arc_,entity,layer) then raise DXF_read_exception.Create('Error reading ARC entity',line_num); end else if (s='ATTDEF') then begin if not general_purpose_read(AttDef_,entity,layer) then raise DXF_read_exception.Create('Error reading ATTDEF entity',line_num); end else if (s='ATTRIB') then begin if not general_purpose_read(Attrib_,entity,layer) then raise DXF_read_exception.Create('Error reading ATTRIB entity',line_num); end else if (s=endstr) then result := true else if skipped<>nil then Skipped.Add(s); end; /////////////////////////////////////////////////////////////////////////////// // Main routines to use /////////////////////////////////////////////////////////////////////////////// function DXF_Reader.read_file : boolean; var lp1 : integer; begin result := true; try mark_position; if not (move_to_header_section and read_header) then begin Sleep(message_delay_ms); goto_marked_position; end; mark_position; if not (move_to_tables_section and read_tables) then begin Sleep(message_delay_ms); goto_marked_position; end; mark_position; if not (move_to_blocks_section and read_blocks) then begin Sleep(message_delay_ms); goto_marked_position; end; mark_position; if not (move_to_entity_section and read_entities) then raise DXF_read_exception.Create('No Entities or invalid Entities section in DXF file',-1); except on E:DXF_read_exception do begin MessageBox(0,@E.message[1],'DXF Read Error',MB_ICONWARNING); end; on E:EAccessViolation do begin MessageDlg(E.message, mtWarning, [mbOK], 0); end; end; if p1_eq_p2_3D(min_extents,origin3D) or p1_eq_p2_3D(max_extents,origin3D) then begin sleep(message_delay_ms); // just a delay to let the message be visible for lp1:=0 to DXF_layers.count-1 do DXF_Layer(DXF_Layers[lp1]).max_min_extents(max_extents,min_extents); end; end; function DXF_Reader.remove_empty_layers : boolean; var lp1 : integer; layer : DXF_layer; begin for lp1 := DXF_Layers.count-1 downto 0 do begin layer := DXF_Layers[lp1]; if layer.num_lists=0 then begin DXF_Layers.Remove(layer); layer.Free; end; end; result := (DXF_Layers.count>0); end; // Hand over ownership of the layers, the owner of the entity lists // is now responsible for their destruction function DXF_Reader.release_control_of_layers : TList; begin result := DXF_Layers; DXF_Layers := nil; end; // Since we're not reading all groupcodes, we offer the chance // to dump the main titles into a list so we can see what // we've missed procedure DXF_Reader.set_skipped_list(s:TStrings); begin skipped := s; end; /////////////////////////////////////////////////////////////////////////////// // DXF File exception /////////////////////////////////////////////////////////////////////////////// constructor DXF_read_exception.create(err_msg:string; line:integer); begin if line>-1 then message := err_msg + #13#10 + 'Error occured at or near line number ' + IntToStr(line) else message := err_msg; end; /////////////////////////////////////////////////////////////////////////////// // DXF UTils /////////////////////////////////////////////////////////////////////////////// function aPoint3D(a,b,c:double) : Point3D; begin result.x := a; result.y := b; result.z := c; end; function p1_eq_p2_3D(p1,p2:Point3D) : boolean; begin result := (p1.x=p2.x) and (p1.y=p2.y) and (p1.z=p2.z); end; function p1_eq_p2_2D(p1,p2:Point3D) : boolean; begin result := (p1.x=p2.x) and (p1.y=p2.y); end; function p1_minus_p2(p1,p2:Point3D) : Point3D; begin result.x := p1.x-p2.x; result.y := p1.y-p2.y; result.z := p1.z-p2.z; end; function p1_plus_p2(p1,p2:Point3D) : Point3D; begin result.x := p1.x+p2.x; result.y := p1.y+p2.y; result.z := p1.z+p2.z; end; function normalize(p1:Point3D) : Point3D; var mag : double; begin mag := Sqrt( sqr(p1.x) + sqr(p1.y) + sqr(p1.z) ); result.x := p1.x/mag; result.y := p1.y/mag; result.z := p1.z/mag; end; function mag(p1:Point3D) : double; begin with p1 do result := Sqrt( sqr(x) + sqr(y) + sqr(z) ); end; function dist3D(p1,p2:Point3D) : double; begin with p1_minus_p2(p2,p1) do result := Sqrt( sqr(x) + sqr(y) + sqr(z) ); end; function dist2D(p1,p2:Point3D) : double; begin with p1_minus_p2(p2,p1) do result := Sqrt( sqr(x) + sqr(y) ); end; function sq_dist3D(p1,p2:Point3D) : double; begin with p1_minus_p2(p2,p1) do result := sqr(x) + sqr(y) + sqr(z); end; function sq_dist2D(p1,p2:Point3D) : double; begin with p1_minus_p2(p2,p1) do result := sqr(x) + sqr(y); end; function sq_mag3D(p1:Point3D) : double; begin with p1 do result := sqr(x) + sqr(y) + sqr(z); end; function p1_x_n(p1:Point3D; n:double) : Point3D; begin result.x := p1.x*n; result.y := p1.y*n; result.z := p1.z*n; end; function set_accuracy(factor:double; p:Point3D) : Point3D; begin result.x := round(p.x*factor)/factor; result.y := round(p.y*factor)/factor; result.z := round(p.z*factor)/factor; end; /////////////////////////////////////////////////////////////////////////////// // Vector 3D stuff /////////////////////////////////////////////////////////////////////////////// function dot(p1,p2:Point3D) : double; begin result := p1.x*p2.x + p1.y*p2.y + p1.z*p2.z; end; function cross(p1,p2:Point3D) : Point3D; begin result.x := p1.y*p2.z - p1.z*p2.y; result.y := p1.z*p2.x - p1.x*p2.z; result.z := p1.x*p2.y - p1.y*p2.x; end; function angle(p1,p2,p3:Point3D; do_3D:boolean) : double; var v1,v2 : Point3D; d1,d2 : double; begin v1 := p1_minus_p2(p2,p1); v2 := p1_minus_p2(p3,p2); if not do_3D then begin v1.z := 0; v2.z := 0; end; d1 := Mag(v1); d2 := Mag(v2); if ((d1=0) or (d2=0)) then result := 0 else begin d1 := dot(v1,v2)/(d1*d2); if abs(d1)<=1 then result := ArcCos(d1) else result := 0; end; end; /////////////////////////////////////////////////////////////////////////////// // Rotations for Insert/Block drawing /////////////////////////////////////////////////////////////////////////////// function XRotateMatrix(cos_a,sin_a:double) : Matrix; begin result := identity; result.val[1,1]:= cos_a; result.val[1,2]:=-sin_a; result.val[2,1]:= sin_a; result.val[2,2]:= cos_a; end; function YRotateMatrix(cos_a,sin_a:double) : Matrix; begin result := identity; result.val[0,0]:= cos_a; result.val[0,2]:= sin_a; result.val[2,0]:=-sin_a; result.val[2,2]:= cos_a; end; function ZRotateMatrix(cos_a,sin_a:double) : Matrix; begin result := identity; result.val[0,0]:= cos_a; result.val[0,1]:=-sin_a; result.val[1,0]:= sin_a; result.val[1,1]:= cos_a; end; function ScaleMatrix(p:Point3D) : Matrix; begin result := identity; result.val[0,0] := p.x; result.val[1,1] := p.y; result.val[2,2] := p.z; end; function TranslateMatrix(p:Point3D) : Matrix; begin result := identity; result.val[3,0] := p.x; result.val[3,1] := p.y; result.val[3,2] := p.z; end; function MatrixMultiply(matrix1,matrix2:matrix) : Matrix; var row,column : integer; begin for row:=0 to 3 do begin for column:=0 to 3 do result.val[row,column]:= matrix1.val[row,0]*matrix2.val[0,column] + matrix1.val[row,1]*matrix2.val[1,column] + matrix1.val[row,2]*matrix2.val[2,column] + matrix1.val[row,3]*matrix2.val[3,column]; end; end; var GlobalTempMatrix : Matrix; function update_transformations(OCS_WCS,OCS:pMatrix) : pMatrix; begin if OCS=nil then result := OCS_WCS else if OCS_WCS=nil then result := OCS else begin GlobalTempMatrix := MatrixMultiply(OCS_WCS^,OCS^); result := @GlobalTempMatrix; end; end; { Matrix order : For reference start with a point at ( cos(30),sin(30),0 ) rotate by 30 degrees - shifts point to (1,0,0) then translate by (10,0,0) shifts to (11,0,0) then rotate by -45 degrees goes to (7.77, 7.77 ,0) 7.77 = Sqrt(11^2 /2 ) NOTE THE ORDER OF MATRIX OPERATIONS ! test := aPoint3D( cos(degtorad(30)) , sin(degtorad(30)) , 0); mat := ZRotateMatrix( cos(degtorad(30)) , sin(degtorad(30)) ); mat := MatrixMultiply( mat , TranslateMatrix(aPoint3D(10,0,0)) ); mat := MatrixMultiply( mat , ZRotateMatrix( cos(degtorad(-45)) , sin(degtorad(-45)) ) ); test := TransformPoint(mat,test); } function CreateTransformation(Ax,Ay,Az:Point3D) : Matrix; begin result := Identity; result.val[0,0] :=Ax.x; result.val[1,0] :=Ay.x; result.val[2,0] :=Az.x; result.val[0,1] :=Ax.y; result.val[1,1] :=Ay.y; result.val[2,1] :=Az.y; result.val[0,2] :=Ax.z; result.val[1,2] :=Ay.z; result.val[2,2] :=Az.z; end; function TransformPoint(TM:Matrix; p:Point3D) : Point3D; begin with TM do begin result.x := p.x*val[0,0] + p.y*val[1,0] + p.z*val[2,0] + val[3,0]; result.y := p.x*val[0,1] + p.y*val[1,1] + p.z*val[2,1] + val[3,1]; result.z := p.x*val[0,2] + p.y*val[1,2] + p.z*val[2,2] + val[3,2]; end; end; function RotationAxis(A:Point3D; angle:double) : Matrix; var sin_a,cos_a : double; begin result := Identity; sin_a := sin(angle); cos_a := cos(angle); result.val[0][0] := (A.x*A.x + (1. - A.x*A.x)*cos_a); result.val[1][0] := (A.x*A.y*(1. - cos_a) + A.z*sin_a); result.val[2][0] := (A.x*A.z*(1. - cos_a) - A.y*sin_a); result.val[0][1] := (A.x*A.y*(1. - cos_a) - A.z*sin_a); result.val[1][1] := (A.y*A.y + (1. - A.y*A.y)*cos_a); result.val[2][1] := (A.y*A.z*(1. - cos_a) + A.x*sin_a); result.val[0][2] := (A.x*A.z*(1. - cos_a) + A.y*sin_a); result.val[1][2] := (A.y*A.z*(1. - cos_a) - A.x*sin_a); result.val[2][2] := (A.z*A.z + (1. - A.z*A.z)*cos_a); end; /////////////////////////////////////////////////////////////////////////////// // Bounds /////////////////////////////////////////////////////////////////////////////// procedure max_bound(var bounds:Point3D; point:Point3D); begin if point.x>bounds.x then bounds.x := point.x; if point.y>bounds.y then bounds.y := point.y; if point.z>bounds.z then bounds.z := point.z; end; procedure min_bound(var bounds:Point3D; point:Point3D); begin if point.xb then result := a else result := b; end; function imax(a,b:integer) : integer; begin if a>b then result :=a else result:=b; end; function imin(a,b:integer) : integer; begin if a>b then result :=b else result:=a; end; /////////////////////////////////////////////////////////////////////////////// // Memory /////////////////////////////////////////////////////////////////////////////// function allocate_points(n:integer) : ppointlist; begin Getmem(result,n*SizeOf(Point3D)); end; procedure deallocate_points(var pts:ppointlist; n:integer); begin Freemem(pts,n*SizeOf(Point3D)); pts := nil; end; function allocate_matrix : pMatrix; begin Getmem(result,SizeOf(Matrix)); end; procedure deallocate_matrix(var m:pMatrix); begin Freemem(m,SizeOf(Matrix)); m := nil; end; /////////////////////////////////////////////////////////////////////////////// // String /////////////////////////////////////////////////////////////////////////////// function float_out(f:double) : string; begin result := FloatToStrF(f,ffFixed,7,3); //result := FloatToStr(f); end; function Point3DToStr(p:Point3D) : string; begin result := '(' + FloatToStrF(p.x,ffFixed,7,2) + ', ' + FloatToStrF(p.y,ffFixed,7,2) + ', ' + FloatToStrF(p.z,ffFixed,7,2) + ')'; end; function BoolToStr(b:boolean) : string; begin if b then result := 'TRUE' else result := 'FALSE'; end; procedure draw_cross(acanvas:TCanvas; p1:TPoint); var pa,pb : TPoint; begin pa.x := p1.x-2; pa.y := p1.y-2; pb.x := p1.x+3; pb.y := p1.y+3; acanvas.Moveto(pa.x,pa.y); acanvas.Lineto(pb.x,pb.y); pa.x := p1.x-2; pa.y := p1.y+2; pb.x := p1.x+3; pb.y := p1.y-3; acanvas.Moveto(pa.x,pa.y); acanvas.Lineto(pb.x,pb.y); end; /////////////////////////////////////////////////////////////////////////////// // DXF_Entity - abstract base class - override where neccessary /////////////////////////////////////////////////////////////////////////////// constructor DXF_Entity.create; begin inc(entities_in_existence); end; destructor DXF_Entity.destroy; begin if OCS_WCS<>nil then deallocate_matrix(OCS_WCS); dec(entities_in_existence); inherited destroy; end; procedure DXF_Entity.init_OCS_WCS_matrix(OCSaxis:Point3D); var Ax,Ay : Point3D; begin OCS_axis := OCSaxis; if not p1_eq_p2_3D(OCSaxis,WCS_Z) then begin OCS_WCS := allocate_matrix; if (abs(OCSaxis.x)<1/64) and (abs(OCSaxis.y)<1/64) then Ax := normalize(cross(WCS_Y,OCSaxis)) else Ax := normalize(cross(WCS_Z,OCSaxis)); Ay := normalize(cross(OCSaxis,Ax)); OCS_WCS^ := CreateTransformation(Ax,Ay,OCSaxis); end; end; procedure DXF_Entity.setcolour_index(col:integer); begin colinx := col; colour := DXF_Layer_Colours[col mod (def_cols+1)]; end; procedure DXF_Entity.setcolour(col:TColor); var lp1 : integer; begin colinx := 0; for lp1:=0 to def_cols do if DXF_Layer_Colours[lp1]=col then colinx := lp1; colour := col; end; function DXF_Entity.count_points : integer; begin result := 1; end; function DXF_Entity.count_lines : integer; begin result := 0; end; function DXF_Entity.count_polys_open : integer; begin result := 0; end; function DXF_Entity.count_polys_closed : integer; begin result := 0; end; function DXF_Entity.proper_name : string; var temp : string; begin temp := UpperCase(ClassName); result := Copy(temp,1,Length(temp)-1); end; procedure DXF_Entity.write_DXF_Point(var IO:textfile; n:integer; p:Point3D); begin writeln(IO, n , EOL,float_out(p.x) ); writeln(IO, n+10 , EOL,float_out(p.y) ); writeln(IO, n+20 , EOL,float_out(p.z) ); end; procedure DXF_Entity.write_to_DXF(var IO:textfile; layer:string); begin writeln(IO,0 ,EOL,proper_name); writeln(IO,8 ,EOL,layer); writeln(IO,62,EOL,colinx); if OCS_WCS<>nil then write_DXF_Point(IO,210,OCS_axis); end; function DXF_Entity.is_point_inside_object2D(p:Point3D) : boolean; begin result := false; end; function DXF_Entity.Move_point(p,newpoint:Point3D) : boolean; begin result := false; end; /////////////////////////////////////////////////////////////////////////////// // Block_ class implementation /////////////////////////////////////////////////////////////////////////////// constructor Block_.create(bname:string; refpoint:Point3D); begin entities := TList.Create; basepoint := refpoint; if not p1_eq_p2_3D(basepoint,origin3D) then begin OCS_WCS := allocate_matrix; OCS_WCS^ := TranslateMatrix(p1_minus_p2(origin3D,basepoint)); end; name := bname; end; destructor Block_.destroy; var lp1 : integer; begin for lp1:=0 to entities.count-1 do DXF_Entity(entities[lp1]).free; entities.Free; end; procedure Block_.update_block_links(blist:TObject); var lp1 : integer; begin for lp1:=0 to entities.count-1 do if (TObject(entities[lp1]) is Insert_) then Insert_(entities[lp1]).update_block_links(blist); end; procedure Block_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var lp1 : integer; t_matrix : pMatrix; TempMatrix : Matrix; begin // we mustn't use the update_transformations call because blocks may be // nested inside blocks inside other blocks, and update_transformations uses // a temp fixed matrix which will be overwritten. if OCS=nil then t_matrix := OCS_WCS else if OCS_WCS=nil then t_matrix := OCS else begin TempMatrix := MatrixMultiply(OCS_WCS^,OCS^); t_matrix := @TempMatrix; end; for lp1:=0 to entities.count-1 do DXF_Entity(entities[lp1]).draw(acanvas,map_fn,t_matrix); end; procedure Block_.DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var lp1 : integer; begin for lp1:=0 to entities.count-1 do DXF_Entity(entities[lp1]).drawvertices(acanvas,map_fn,OCS); end; function Block_.details : string; var lp1 : integer; begin result := 'Name :'#9 + name + EOL + 'Base :'#9 + Point3DToStr(basepoint); for lp1:=0 to entities.count-1 do result := result + EOL + EOL + DXF_Entity(entities[lp1]).details; end; procedure Block_.write_to_DXF(var IO:textfile; layer:string); var lp1 : integer; begin writeln(IO,0 ,EOL,proper_name); writeln(IO,8 ,EOL,layer); writeln(IO,2 ,EOL,name); write_DXF_Point(IO,10,basepoint); for lp1:=0 to entities.count-1 do DXF_Entity(entities[lp1]).write_to_DXF(IO,layer); writeln(IO,0 ,EOL,'ENDBLK'); end; procedure Block_.max_min_extents(var emax,emin:Point3D); begin end; function Block_.closest_vertex_square_distance_2D(p:Point3D) : double; begin result := 1E9; end; function Block_.closest_vertex(p:Point3D) : Point3D; begin result := aPoint3D(1E9,1E9,1E9); end; /////////////////////////////////////////////////////////////////////////////// // Point /////////////////////////////////////////////////////////////////////////////// constructor Point_.create(OCSaxis,p:Point3D; col:integer); begin inherited create; p1 := p; setcolour_index(col); init_OCS_WCS_matrix(OCSaxis); end; procedure Point_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var po : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; po := map_fn(p1,t_matrix); draw_cross(acanvas,po); end; procedure Point_.DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var po : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; po := map_fn(p1,t_matrix); draw_cross(acanvas,po); end; procedure Point_.translate(T:Point3D); begin p1 := p1_plus_p2(p1,T); end; procedure Point_.quantize_coords(epsilon:double; mask:byte); begin if (mask and 1)=1 then p1.x := round(p1.x*epsilon)/epsilon; if (mask and 2)=2 then p1.y := round(p1.y*epsilon)/epsilon; if (mask and 4)=4 then p1.z := round(p1.z*epsilon)/epsilon; end; function Point_.details : string; var t : string; begin if OCS_WCS<>nil then t := 'OCS Axis ' + Point3DToStr(OCS_axis) else t := 'WCS'; result := ClassName + EOL + t + EOL + Point3DToStr(p1); end; procedure Point_.write_to_DXF(var IO:textfile; layer:string); begin inherited; write_DXF_Point(IO,10,p1); end; procedure Point_.max_min_extents(var emax,emin:Point3D); begin max_bound(emax,p1); min_bound(emin,p1); end; function Point_.closest_vertex_square_distance_2D(p:Point3D) : double; begin result := sq_dist2D(p1,p); end; function Point_.closest_vertex(p:Point3D) : Point3D; begin result := p1; end; function Point_.Move_point(p,newpoint:Point3D) : boolean; begin if p1_eq_p2_3D(p1,p) then begin p1 := newpoint; result := true; end else result := false; end; /////////////////////////////////////////////////////////////////////////////// // Text /////////////////////////////////////////////////////////////////////////////// constructor Text_.create(OCSaxis,p,ap:Point3D; ss:string; height:double; col,ha:integer); begin inherited create(OCSaxis,p,col); h := height; if ss<>'' then textstr := ss; if p1_eq_p2_3D(ap,origin3D) then ap:=p; align_pt := ap; hor_align := ha; end; procedure Text_.calcText(acanvas:TCanvas; map_fn:coord_convert; OCS:pM; t:string); var pa,dummy1,dummy2 : TPoint; Fheight : integer; begin with acanvas.Pen do if Color<>colour then Color:=colour; // kludgy method for scaling text heights dummy1 := map_fn(origin3D,nil); dummy2 := map_fn(aPoint3D(0,h,0),nil); Fheight := 2+(dummy1.y-dummy2.y); if FHeight=2 then exit; with acanvas.Font do begin if Height<>Fheight then Height := Fheight; if color<>colour then color := colour; end; case hor_align of 0 : SetTextAlign(acanvas.handle,TA_LEFT + TA_BASELINE); 1 : SetTextAlign(acanvas.handle,TA_CENTER + TA_BASELINE); 2 : SetTextAlign(acanvas.handle,TA_RIGHT + TA_BASELINE); end; pa := map_fn(align_pt,OCS_WCS); acanvas.TextOut(pa.x,pa.y,t); end; procedure Text_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); calcText(acanvas,map_fn,t_matrix,textstr); end; function Text_.details : string; begin result := inherited details + EOL + 'Text '#9 + textstr + EOL + 'TextHeight = ' + float_out(h); end; procedure Text_.write_to_DXF(var IO:textfile; layer:string); begin inherited; writeln(IO,40 ,EOL,float_out(h)); writeln(IO,1 ,EOL,textstr); if hor_align<>0 then begin write_DXF_Point(IO,11,align_pt); writeln(IO,72 ,EOL,hor_align); end; end; procedure Text_.max_min_extents(var emax,emin:Point3D); begin max_bound(emax,p1); min_bound(emin,p1); end; /////////////////////////////////////////////////////////////////////////////// // Attrib /////////////////////////////////////////////////////////////////////////////// constructor Attrib_.create(OCSaxis,p,ap:Point3D; ss,tag:string; flag70,flag72:integer; height:double; col:integer); begin inherited create(OCSaxis,p,ap,ss,height,col,flag72); tagstr := tag; if (flag70 and 1)=1 then visible:=false else visible := true; end; procedure Attrib_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); if not visible then exit; calcText(acanvas,map_fn,t_matrix,tagstr); end; function Attrib_.details : string; var t : string; begin if visible then t:='Visible' else t:='Invisible'; result := inherited details + EOL + 'Tag '#9 + TagStr + EOL + t; end; procedure Attrib_.write_to_DXF(var IO:textfile; layer:string); begin inherited; writeln(IO,2 ,EOL,tagstr); if visible then writeln(IO,70 ,EOL,0) else writeln(IO,70 ,EOL,1) end; /////////////////////////////////////////////////////////////////////////////// // Attdef /////////////////////////////////////////////////////////////////////////////// constructor Attdef_.create(OCSaxis,p,ap:Point3D; ss,tag,prompt:string; flag70,flag72:integer; height:double; col:integer); begin inherited create(OCSaxis,p,ap,ss,tag,flag70,flag72,height,col); promptstr := prompt; end; procedure Attdef_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); begin // Attdefs are used in the blocks section to act as templates for Attribs // so no need to draw them as there will be an Attrib in its place end; procedure Attdef_.write_to_DXF(var IO:textfile; layer:string); begin inherited; writeln(IO,DXF_text_prompt ,EOL,promptstr); end; /////////////////////////////////////////////////////////////////////////////// // Insert /////////////////////////////////////////////////////////////////////////////// constructor Insert_.create(OCSaxis,p,s_f:Point3D; rot:double; col:integer; numatts:integer; atts:patt_array; block:string); var lp1 : integer; begin inherited create(OCSaxis,p,col); blockname := block; blockptr := nil; scale := s_f; rotation := DegToRad(rot); init_OCS_WCS_matrix(OCSaxis); num_attribs := numatts; if num_attribs>max_attribs then raise Exception.Create('This version only handles '+IntToStr(max_attribs)+' ATTRIBs'); for lp1:=0 to num_attribs-1 do attribs[lp1] := atts^[lp1]; end; destructor Insert_.destroy; var lp1 : integer; begin for lp1:=0 to num_attribs-1 do attribs[lp1].Free; inherited destroy; end; procedure Insert_.init_OCS_WCS_matrix(OCSaxis:Point3D); var Ax,Ay : Point3D; begin // inserts always have a transformation matrix - to allow the translation // even when the other parameters are defauls OCS_axis := OCSaxis; OCS_WCS := allocate_matrix; if (abs(OCSaxis.x)<1/64) and (abs(OCSaxis.y)<1/64) then Ax := normalize(cross(WCS_Y,OCSaxis)) else Ax := normalize(cross(WCS_Z,OCSaxis)); Ay := normalize(cross(OCSaxis,Ax)); OCS_WCS^ := Identity; OCS_WCS^ := MatrixMultiply(OCS_WCS^, ZRotateMatrix(cos(-rotation),sin(-rotation))); OCS_WCS^ := MatrixMultiply(OCS_WCS^, ScaleMatrix(scale) ); OCS_WCS^ := MatrixMultiply(OCS_WCS^, TranslateMatrix(p1) ); OCS_WCS^ := MatrixMultiply(OCS_WCS^, CreateTransformation(Ax,Ay,OCSaxis) ); end; procedure Insert_.update_block_links(blist:TObject); begin blocklist := blist; if blockname<>'' then block.update_block_links(blist); end; // instead of searching for the block every time it's needed, we'll store // the object pointer after the first time it's used, and return it // when needed. Only use this function to access it - for safety. function Insert_.block : Block_; var lp1 : integer; begin if blockptr=nil then begin // this bit called once for lp1:=0 to Entity_List(blocklist).entities.count-1 do begin if Block_(Entity_List(blocklist).entities[lp1]).name=blockname then begin blockptr := Block_(Entity_List(blocklist).entities[lp1]); result := blockptr; exit; end; end; end // this bit every subsequent time else result := blockptr; if result=nil then raise Exception.Create('Block reference '+blockname+' not found'); end; procedure Insert_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var lp1 : integer; t_matrix : pMatrix; TempMatrix : Matrix; begin // we mustn't use the update_transformations call because inserts may be // nested inside blocks inside other blocks, and update_transformations uses // a temp fixed matrix which will be overwritten. if OCS=nil then t_matrix := OCS_WCS else if OCS_WCS=nil then t_matrix := OCS else begin TempMatrix := MatrixMultiply(OCS_WCS^,OCS^); t_matrix := @TempMatrix; end; for lp1:=0 to num_attribs-1 do attribs[lp1].Draw(acanvas,map_fn,t_matrix); if blockname<>'' then block.Draw(acanvas,map_fn,t_matrix); end; function Insert_.details : string; var lp1 : integer; begin result := inherited details + EOL + 'Block '#9 + blockname + EOL + 'Scaling'#9 + Point3DToStr(scale) + EOL + 'Rotation'#9 + float_out(RadToDeg(rotation)) + EOL + 'Attribs '#9 + IntToStr(num_attribs); for lp1:=0 to num_attribs-1 do begin result := result + EOL + EOL; result := result + IntToStr(lp1+1) + ' : ' + attribs[lp1].details; end; result := result + EOL + EOL + '----BLOCK-----' + EOL + block.details + EOL + '---ENDBLOCK---'; end; procedure Insert_.write_to_DXF(var IO:textfile; layer:string); var lp1 : integer; begin inherited; if blockname<>'' then writeln(IO,2,EOL,blockname); if (scale.x<>1) or (scale.y<>1) or (scale.z<>1) then begin writeln(IO,41,EOL,float_out(scale.x)); writeln(IO,42,EOL,float_out(scale.y)); writeln(IO,43,EOL,float_out(scale.z)); end; if rotation<>0 then writeln(IO,50,EOL,float_out(RadToDeg(rotation))); if num_attribs>0 then begin writeln(IO,66,EOL,1); for lp1:=0 to num_attribs-1 do attribs[lp1].write_to_DXF(IO,layer); writeln(IO,0,EOL,'SEQEND'); end else writeln(IO,66,EOL,0); end; procedure Insert_.max_min_extents(var emax,emin:Point3D); begin inherited; end; /////////////////////////////////////////////////////////////////////////////// // Line /////////////////////////////////////////////////////////////////////////////// constructor Line_.create(p_1,p_2:Point3D; col:integer); begin inherited create(WCS_Z,p_1,col); p2 := p_2; end; procedure Line_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var pa,pb : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; pa := map_fn(p1,t_matrix); pb := map_fn(p2,t_matrix); acanvas.Moveto(pa.x,pa.y); acanvas.Lineto(pb.x,pb.y); end; procedure Line_.DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var po : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; po := map_fn(p1,t_matrix); draw_cross(acanvas,po); po := map_fn(p2,t_matrix); draw_cross(acanvas,po); end; procedure Line_.translate(T:Point3D); begin p1 := p1_plus_p2(p1,T); p2 := p1_plus_p2(p2,T); end; procedure Line_.quantize_coords(epsilon:double; mask:byte); begin if (mask and 1)=1 then begin p1.x := round(p1.x*epsilon)/epsilon; p2.x := round(p2.x*epsilon)/epsilon; end; if (mask and 2)=2 then begin p1.y := round(p1.y*epsilon)/epsilon; p2.y := round(p2.y*epsilon)/epsilon; end; if (mask and 4)=4 then begin p1.z := round(p1.z*epsilon)/epsilon; p2.z := round(p2.z*epsilon)/epsilon; end; end; function Line_.count_points : integer; begin result := 2; end; function Line_.count_lines : integer; begin result := 1; end; function Line_.details : string; begin result := inherited details + EOL + Point3DToStr(p2); end; procedure Line_.write_to_DXF(var IO:textfile; layer:string); begin inherited; write_DXF_Point(IO,11,p2); end; procedure Line_.max_min_extents(var emax,emin:Point3D); begin max_bound(emax,p1); min_bound(emin,p1); max_bound(emax,p2); min_bound(emin,p2); end; function Line_.closest_vertex_square_distance_2D(p:Point3D) : double; begin result := dmin(sq_dist2D(p1,p),sq_dist2D(p2,p)); end; function Line_.closest_vertex(p:Point3D) : Point3D; begin if sq_dist2D(p1,p)colour then Color:=colour; pa := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pb := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); // bug in Ellipse routine causes crash if extents are too small if (pb.x>pa.x+1) and (pa.y>pb.y+1) then acanvas.Ellipse(pa.x,pa.y,pb.x,pb.y) else acanvas.pixels[pa.x,pa.y] := acanvas.Pen.Color; end; function Circle_.details : string; begin result := inherited details + EOL + 'Radius = ' + float_out(radius); end; procedure Circle_.write_to_DXF(var IO:textfile; layer:string); begin inherited; writeln(IO,40,EOL,float_out(radius)); end; function Circle_.is_point_inside_object2D(p:Point3D) : boolean; begin result := dist2D(p,p1)<=radius; end; procedure Circle_.max_min_extents(var emax,emin:Point3D); var lp1 : integer; begin max_bound(emax, p1_plus_p2 (p1, aPoint3D(radius,radius,0))); min_bound(emin, p1_minus_p2(p1, aPoint3D(radius,radius,0))); end; /////////////////////////////////////////////////////////////////////////////// // Arc /////////////////////////////////////////////////////////////////////////////// constructor Arc_.create(OCSaxis,p_1:Point3D; radius_,sa,ea:double; col:integer); begin inherited create(OCSaxis,p_1,radius_,col); angle1 := DegToRad(sa); angle2 := DegToRad(ea); end; procedure Arc_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var pu,pv,pw,px : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; pu := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pv := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); pw := map_fn(aPoint3D(p1.x+cos(angle1)*radius,p1.y+sin(angle1)*radius,p1.z+radius),t_matrix); px := map_fn(aPoint3D(p1.x+cos(angle2)*radius,p1.y+sin(angle2)*radius,p1.z+radius),t_matrix); if (pv.x>pu.x+1) and (pu.y>pv.y+1) then acanvas.Arc(pu.x,pu.y,pv.x,pv.y,pw.x,pw.y,px.x,px.y) else acanvas.pixels[pu.x,pu.y] := acanvas.Pen.Color; end; function Arc_.details : string; begin result := inherited details + EOL + 'Angle 1 = ' + float_out(angle1) + EOL + 'Angle 2 = ' + float_out(angle2); end; procedure Arc_.write_to_DXF(var IO:textfile; layer:string); begin inherited; writeln(IO,50,EOL,float_out(RadToDeg(angle1))); writeln(IO,51,EOL,float_out(RadToDeg(angle2))); end; function Arc_.is_point_inside_object2D(p:Point3D) : boolean; begin result := false; end; procedure Arc_.max_min_extents(var emax,emin:Point3D); var lp1 : integer; ax,ay,bx,by : double; thisboundary : integer; lastboundary : integer; begin // the end points of the arc ax := p1.x + radius*cos(angle1); ay := p1.y + radius*sin(angle1); bx := p1.x + radius*cos(angle2); by := p1.y + radius*sin(angle2); max_bound(emax, aPoint3D(ax,ay,0)); min_bound(emin, aPoint3D(ax,ay,0)); max_bound(emax, aPoint3D(bx,by,0)); min_bound(emin, aPoint3D(bx,by,0)); // long arcs may extend along the axes (quadrants) (eg 1 to 359 ->90,180,270) lastboundary := 90*((trunc(RadToDeg(angle2))+89) div 90); if lastboundary=360 then lastboundary := 0; thisboundary := 90*((trunc(RadToDeg(angle1))+90) div 90); if thisboundary=360 then thisboundary := 0; while thisboundary<>lastboundary do begin ax := p1.x + radius*cos(DegToRad(thisboundary)); ay := p1.y + radius*sin(DegToRad(thisboundary)); max_bound(emax, aPoint3D(ax,ay,0)); min_bound(emin, aPoint3D(ax,ay,0)); thisboundary := thisboundary+90; if thisboundary=360 then thisboundary := 0; end; end; /////////////////////////////////////////////////////////////////////////////// // Polyline /////////////////////////////////////////////////////////////////////////////// constructor Polyline_.create(OCSaxis:Point3D; numpoints:integer; points:ppointlist; col:integer; closed_:boolean); var lp1 : integer; begin inherited create; init_OCS_WCS_matrix(OCSaxis); numvertices := numpoints; if closed_ then closed := true else if p1_eq_p2_3D(points[0],points[numvertices-1]) then begin closed := true; dec(numvertices); end else closed := false; polypoints := allocate_points(numvertices); for lp1:=0 to numvertices-1 do polypoints^[lp1] := points^[lp1]; setcolour_index(col); end; destructor Polyline_.destroy; begin deallocate_points(polypoints,numvertices); inherited destroy; end; procedure Polyline_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..max_vertices_per_polyline-1] of TPoint; lp1,tn : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); if not closed then acanvas.Polyline(Slice(PointArray,numvertices)) else acanvas.Polygon(Slice(PointArray,numvertices)); end; procedure Polyline_.DrawVertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var po : TPoint; lp1 : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numvertices-1 do begin po := map_fn(polypoints^[lp1],t_matrix); draw_cross(acanvas,po); end; end; procedure Polyline_.translate(T:Point3D); var lp1 : integer; begin for lp1:=0 to numvertices-1 do polypoints^[lp1] := p1_plus_p2(polypoints^[lp1],T); end; procedure Polyline_.quantize_coords(epsilon:double; mask:byte); var lp1 : integer; begin for lp1:=0 to numvertices-1 do begin if (mask and 1)=1 then polypoints^[lp1].x := round(polypoints^[lp1].x*epsilon)/epsilon; if (mask and 2)=2 then polypoints^[lp1].y := round(polypoints^[lp1].y*epsilon)/epsilon; if (mask and 4)=4 then polypoints^[lp1].z := round(polypoints^[lp1].z*epsilon)/epsilon; end; end; function Polyline_.count_points : integer; begin result := numvertices; end; function Polyline_.count_lines : integer; begin result := numvertices; end; function Polyline_.count_polys_open : integer; begin if not closed then result := 1 else result := 0;end; function Polyline_.count_polys_closed : integer; begin if closed then result := 1 else result := 0;end; function Polyline_.details : string; var lp1 : integer; t : string; begin if OCS_WCS<>nil then t := 'OCS Axis ' + Point3DToStr(OCS_axis) else t := 'WCS'; result := classname + EOL + t; if closed then result := result + EOL + 'Closed' else result := result + EOL + 'Open'; for lp1:=0 to numvertices-1 do result := result + EOL + Point3DToStr(polypoints^[lp1]); end; procedure Polyline_.write_to_DXF(var IO:textfile; layer:string); var lp1 : integer; begin inherited; if closed then writeln(IO,70 ,EOL,1+8) // 1+8 = closed+3D else writeln(IO,70 ,EOL,8); for lp1:=0 to numvertices-1 do begin writeln(IO,0 ,EOL,'VERTEX'); writeln(IO,70 ,EOL,32); // 3D polyline mesh vertex write_DXF_Point(IO, 10, polypoints^[lp1]); end; writeln(IO,0 ,EOL,'SEQEND'); end; procedure Polyline_.max_min_extents(var emax,emin:Point3D); var lp1 : integer; begin for lp1:=0 to numvertices-1 do begin max_bound(emax,polypoints^[lp1]); min_bound(emin,polypoints^[lp1]); end; end; function Polyline_.closest_vertex_square_distance_2D(p:Point3D) : double; var lp1 : integer; begin result := 1E10; for lp1:=0 to numvertices-1 do result := dmin(result,sq_dist2D(polypoints^[lp1],p)); end; function Polyline_.closest_vertex(p:Point3D) : Point3D; var lp1,c : integer; d1,d2 : double; begin d1 := 1E10; for lp1:=0 to numvertices-1 do begin d2 := sq_dist2D(polypoints^[lp1],p); if d23 then raise Exception.Create('Shouldn''t call this for non triangular facets'); s := 1; t := 2; result := p1_plus_p2(polypoints^[0],p1_plus_p2(polypoints^[s],polypoints^[t])); result := p1_x_n(result,1/3); end; procedure Polyline_.set_attrib(i:integer; v:double); begin if (i+1)>numattrs then numattrs:=(i+1); attribs[i] := v; end; function Polyline_.get_attrib(i:integer) : double; begin if i>=numattrs then result := 0 else result := attribs[i]; end; procedure Polyline_.copy_attribs(p:Polyline_); var lp1 : integer; begin p.numattrs := numattrs; for lp1:=0 to numattrs-1 do p.attribs[lp1] := attribs[lp1]; end; function Polyline_.is_point_inside_object2D(p:Point3D) : boolean; var i,j : integer; p1_i,p1_j : Point3D; begin result := false; if not closed then exit; j := numvertices-1; for i:=0 to numvertices-1 do with p do begin p1_i := polypoints^[i]; p1_j := polypoints^[j]; if ((((p1_i.y<=y) and (ynil then t := 'OCS Axis ' + Point3DToStr(OCS_axis) else t := 'WCS'; result := 'Polyline_ (polygon mesh)' + EOL + t + EOL + 'Vertices'#9 + IntToStr(numvertices) + EOL + 'M'#9 + IntToStr(M) + EOL + 'N'#9 + IntToStr(N) + EOL + 'Closed M'#9 + BoolToStr(closeM) + EOL + 'Closed N'#9 + BoolToStr(closeN); end; type ptarray = array[0..max_vertices_per_polyline-1] of TPoint; pptarray = ^ptarray; procedure Polygon_mesh_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..max_vertices_per_polyline-1] of TPoint; tp : TPoint; lp1,lp2,inx : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); // draw the M N-length polylines - we can use the array directly if closeN then for lp1:=0 to M-1 do acanvas.Polygon( Slice(pptarray(@PointArray[N*lp1])^,N)) else for lp1:=0 to M-1 do acanvas.Polyline(Slice(pptarray(@PointArray[N*lp1])^,N)); // draw the N M-length polylines - we need to hop along the array in M steps for lp1:=0 to N-1 do begin acanvas.MoveTo(PointArray[lp1].x,PointArray[lp1].y); for lp2:=1 to M-1 do begin tp := PointArray[lp2*N+lp1]; acanvas.LineTo(tp.x,tp.y); end; if closeM then acanvas.LineTo(PointArray[lp1].x,PointArray[lp1].y); end; end; /////////////////////////////////////////////////////////////////////////////// // Polyline_ (polyface vertex array mesh) /////////////////////////////////////////////////////////////////////////////// constructor Polyface_mesh_.create(numpoints,nfaces:integer; points:ppointlist; faces:pfacelist; col:integer); var lp1 : integer; begin DXF_Entity.create; // don't call polyline_constructor numvertices := numpoints; numfaces := nfaces; polypoints := allocate_points(numvertices); for lp1:=0 to numvertices-1 do polypoints^[lp1] := points^[lp1]; Getmem(facelist,numfaces*SizeOf(polyface)); for lp1:=0 to numfaces-1 do facelist^[lp1] := faces^[lp1]; setcolour_index(col); end; destructor Polyface_mesh_.destroy; begin Freemem(facelist,numfaces*SizeOf(polyface)); inherited destroy; end; function Polyface_mesh_.proper_name : string; begin result := 'POLYLINE'; end; procedure Polyface_mesh_.write_to_DXF(var IO:textfile; layer:string); var lp1,lp2,inx : integer; begin writeln(IO,0 ,EOL,proper_name); writeln(IO,8 ,EOL,layer); writeln(IO,62,EOL,colinx); writeln(IO,66,EOL,1); writeln(IO,70,EOL,64); writeln(IO,71,EOL,numvertices); writeln(IO,72,EOL,numfaces); for lp1:=0 to numvertices-1 do begin writeln(IO,0 ,EOL,'VERTEX'); writeln(IO,70 ,EOL,64+128); // polyface mesh coordinate vertex write_DXF_Point(IO, 10, polypoints^[lp1]); end; for lp1:=0 to numfaces-1 do begin writeln(IO,0 ,EOL,'VERTEX'); writeln(IO,70 ,EOL,128); // polyface mesh face vertex for lp2:=0 to 3 do writeln(IO,71+lp2 ,EOL,facelist^[lp1].nf[lp2]+1); end; writeln(IO,0 ,EOL,'SEQEND'); end; function Polyface_mesh_.details : string; var t : string; begin if OCS_WCS<>nil then t := 'OCS Axis ' + Point3DToStr(OCS_axis) else t := 'WCS'; result := 'Polyline_ (polyface mesh)' + EOL + t + EOL + 'Vertices'#9 + IntToStr(numvertices) + EOL + 'Faces'#9 + IntToStr(numfaces); end; procedure Polyface_mesh_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..3] of TPoint; lp1,lp2,inx : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numfaces-1 do begin for lp2:=0 to 3 do begin inx := facelist^[lp1].nf[lp2]; if inx<0 then break; // index -> -1 = end of vertices PointArray[lp2] := map_fn(polypoints^[inx],t_matrix); end; acanvas.Polygon(Slice(PointArray,lp2)); end; end; /////////////////////////////////////////////////////////////////////////////// // Entity_List class implementation /////////////////////////////////////////////////////////////////////////////// constructor Entity_List.create(l_name:string); begin list_name := l_name; entities := TList.Create; inc(Ent_lists_in_existence); end; destructor Entity_List.destroy; var lp1 : integer; begin for lp1:=0 to (entities.Count-1) do DXF_Entity(entities[lp1]).Free; entities.Free; dec(Ent_lists_in_existence); inherited destroy; end; function Entity_List.add_entity_to_list(entity:DXF_Entity) : boolean; begin if sorted then result := insert(entity) else result := add_at_end(entity); end; function Entity_List.remove_entity(ent:DXF_Entity) : boolean; var lp1 : integer; begin result := false; for lp1:=0 to (entities.Count-1) do begin if entities[lp1]=ent then begin entities.remove(ent); ent.free; result := true; exit; end; end; end; function Entity_List.add_at_end(entity:DXF_Entity) : boolean; begin entities.Add(entity); end; function Entity_List.insert(entity:DXF_Entity) : boolean; begin entities.Add(entity); end; procedure Entity_List.draw_primitives(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var lp1 : integer; begin for lp1:=0 to (entities.Count-1) do begin DXF_Entity(entities[lp1]).Draw(acanvas, map_fn,OCS); end; end; procedure Entity_List.draw_vertices(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var lp1 : integer; begin for lp1:=0 to (entities.Count-1) do DXF_Entity(entities[lp1]).DrawVertices(acanvas, map_fn,OCS); end; function Entity_List.num_entities : integer; begin result := entities.Count; end; function Entity_List.count_points : integer; var lp1 : integer; begin result := 0; for lp1:=0 to (entities.Count-1) do result := result + DXF_Entity(entities[lp1]).count_points; end; function Entity_List.count_lines : integer; var lp1 : integer; begin result := 0; for lp1:=0 to (entities.Count-1) do result := result + DXF_Entity(entities[lp1]).count_lines; end; function Entity_List.count_polys_open : integer; var lp1 : integer; begin result := 0; for lp1:=0 to (entities.Count-1) do result := result + DXF_Entity(entities[lp1]).count_polys_open; end; function Entity_List.count_polys_closed : integer; var lp1 : integer; begin result := 0; for lp1:=0 to (entities.Count-1) do result := result + DXF_Entity(entities[lp1]).count_polys_closed; end; procedure Entity_List.max_min_extents(var emax,emin:Point3D); var lp1 : integer; begin for lp1:=0 to (entities.Count-1) do DXF_Entity(entities[lp1]).max_min_extents(emax,emin); end; procedure Entity_List.setcolour(col:integer); var lp1 : integer; begin for lp1:=0 to (entities.Count-1) do DXF_Entity(entities[lp1]).colour := col; end; function Entity_List.closest_vertex_square_distance_2D(p:Point3D; var cl:DXF_Entity) : double; var lp1 : integer; cl_ : DXF_Entity; t : double; begin result := 1E10; for lp1:=0 to (entities.Count-1) do begin cl_ := DXF_Entity(entities[lp1]); t := cl_.closest_vertex_square_distance_2D(p); if t0 then for lp1:=num_lists-1 downto 0 do begin el := Entity_List(entity_lists[lp1]); el.Free; end; entity_names.Free; entity_lists.Free; dec(layers_in_existence); inherited destroy; end; procedure DXF_Layer.delete(aname:string; releasemem:boolean); var lp1 : integer; el : Entity_List; begin for lp1:=num_lists-1 downto 0 do begin el := Entity_List(entity_lists[lp1]); if el.name=aname then begin entity_lists.remove(el); if releasemem then el.Free; entity_names.delete(lp1); end; end; end; function DXF_Layer.add_entity_to_layer(entity:DXF_Entity) : boolean; var i : integer; el : Entity_List; begin i := entity_names.IndexOf(entity.ClassName); if i=-1 then begin el := Entity_List.create(entity.ClassName); el.parent_layer := self; i := entity_lists.Add(el); if i<>entity_names.Add(entity.ClassName) then raise Exception.Create('Entity list ID mismatch'); // This has never been raised yet, but might as well be sure. end; Entity_List(entity_lists[i]).add_entity_to_list(entity); if ((entity.colour=0) or (entity.colour=BYLAYER)) then entity.setcolour_index(layer_colinx); result := true; end; procedure DXF_Layer.add_entity_list(elist:Entity_List); var i : integer; begin i := entity_names.IndexOf(elist.name); if i<>-1 then raise Exception.create('Attempted to add two lists with same name'); elist.parent_layer := self; i := entity_lists.Add(elist); if i<>entity_names.Add(elist.Name) then raise Exception.Create('Entity list ID mismatch'); end; function DXF_Layer.num_lists : integer; begin result := entity_names.Count; end; procedure DXF_Layer.max_min_extents(var emax,emin:Point3D); var lp1 : integer; begin for lp1:=0 to num_lists-1 do Entity_List(entity_lists[lp1]).max_min_extents(emax,emin); end; function DXF_Layer.create_or_find_list_type(aname:string) : Entity_List; var inx : integer; begin inx := entity_names.IndexOf(aname); if inx=-1 then begin result := Entity_List.create(aname); result.parent_layer := self; inx := entity_lists.Add(result); if inx<>entity_names.Add(aname) then raise Exception.Create('Entity list ID mismatch'); end else result := Entity_List(entity_lists[inx]); end; /////////////////////////////////////////////////////////////////////////////// // DXF_Object class implementation /////////////////////////////////////////////////////////////////////////////// constructor DXF_Object.create(aname:string); begin layer_lists := TList.create; if aname<>'' then DXF_name := aname else DXF_name := 'Untitled'; emax := origin3D; emin := origin3D; inc(DXF_Obj_in_existence); end; constructor DXF_Object.create_from_file(aname:string; skipped:Tstrings); var reader : DXF_Reader; begin Reader:=DXF_Reader.Create(aname); Reader.set_skipped_list(skipped); With Reader do if (read_file) then begin name := ExtractFileName(aname); emax := get_max_extent; emin := get_min_extent; layer_lists := release_control_of_layers; end else begin layer_lists := TList.create; DXF_name := aname; emax := origin3D; emin := origin3D; end; Reader.Free; inc(DXF_Obj_in_existence); end; destructor DXF_Object.destroy; var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do DXF_Layer(layer_lists.Items[lp1]).Free; layer_lists.Free; dec(DXF_Obj_in_existence); inherited destroy; end; procedure DXF_Object.save_to_file(aname:string); var Writer : DXF_Writer; begin writer := DXF_writer.create(aname,layer_lists); writer.write_file; writer.free; end; function DXF_Object.num_layers : integer; begin result := layer_lists.Count end; function DXF_Object.new_layer(aname:string; DUPs_OK:boolean) : DXF_Layer; var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do begin if DXF_Layer(layer_lists[lp1]).name=aname then begin if not DUPs_OK then raise DXF_Exception.Create('Attempted to create layer with existing name'); result := DXF_Layer(layer_lists[lp1]); exit; end; end; result := DXF_Layer.Create(aname); layer_lists.Add(result); end; function DXF_Object.add_layer(layer:DXF_Layer) : boolean; var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do if DXF_Layer(layer_lists[lp1]).name=layer.name then raise DXF_Exception.Create('Attempted to add layer with existing name'); layer_lists.Add(layer); end; function DXF_Object.layer(aname:string) : DXF_Layer; var lp1 : integer; begin result := nil; for lp1:=0 to layer_lists.Count-1 do if DXF_Layer(layer_lists[lp1]).name=aname then begin result := DXF_Layer(layer_lists[lp1]); exit; end; end; // Avoid using this if possible because we have to search for layer name every time function DXF_Object.add_entity_to_layer(entity:DXF_Entity; aname:string) : boolean; var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do if DXF_Layer(layer_lists[lp1]).name=aname then begin DXF_Layer(layer_lists[lp1]).add_entity_to_layer(entity); result := true; exit; end; raise DXF_Exception.Create('Attempted to add to unnamed layer'); end; function DXF_Object.create_or_find_layer(aname:string) : DXF_Layer; var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do if DXF_Layer(layer_lists[lp1]).name=aname then begin result := DXF_Layer(layer_lists[lp1]); exit; end; result := new_layer(aname, true); end; function DXF_Object.merge_files(DXF_:DXF_Object) : boolean; var lp1,lp2,lp3,lp4 : integer; layer1,layer2 : DXF_Layer; elist1,elist2,blist : Entity_List; ent : DXF_Entity; begin // rather annoyingly we have to keep track of insert/block lookups layer2 := create_or_find_layer('0'); blist := layer2.create_or_find_list_type('Block_'); // for lp1:=0 to DXF_.layer_lists.Count-1 do begin layer1 := DXF_.layer_lists[lp1]; layer2 := create_or_find_layer(layer1.name); for lp2:=0 to layer1.entity_lists.count-1 do begin elist1 := layer1.entity_lists[lp2]; elist2 := layer2.create_or_find_list_type(elist1.name); for lp3:=elist1.entities.count-1 downto 0 do begin ent := elist1.entities[lp3]; elist2.Add_entity_to_list(ent); elist1.entities.remove(ent); if ent is Insert_ then ent.update_block_links(blist); end; end; end; end; procedure DXF_Object.remove_empty_layers_and_lists; var lp1,lp2 : integer; layer : DXF_Layer; el : Entity_List; begin for lp1:=layer_lists.Count-1 downto 0 do begin layer := DXF_Layer(layer_lists[lp1]); for lp2:=layer.num_lists-1 downto 0 do begin el := Entity_List(layer.entity_lists[lp2]); if el.num_entities=0 then begin layer.entity_lists.remove(el); layer.entity_names.delete(lp2); el.Free; if layer.entity_lists.count<>layer.entity_names.count then showmessage('Internal error : Layer lists and names mismatch'); end; end; if layer.num_lists=0 then begin layer_lists.remove(layer); layer.Free; end; end; end; procedure DXF_Object.copy_to_strings(ts:TStrings); var lp1,lp2,pos : integer; layer : DXF_Layer; begin ts.Add(DXF_name); for lp1:=0 to layer_lists.count-1 do begin layer := layer_lists[lp1]; pos := ts.Add(' '+layer.name); ts.Objects[pos] := layer; for lp2:=0 to layer.num_lists-1 do begin pos := ts.Add(' '+Entity_List(layer.entity_lists[lp2]).name); ts.Objects[pos] := layer.entity_lists[lp2]; end; end; end; function DXF_Object.get_min_extent : Point3D; begin result := emin; end; function DXF_Object.get_max_extent : Point3D; begin result := emax; end; procedure DXF_Object.max_min_extents(var emax,emin:Point3D); var lp1 : integer; begin for lp1:=0 to layer_lists.Count-1 do DXF_Layer(layer_lists[lp1]).max_min_extents(emax,emin); end; /////////////////////////////////////////////////////////////////////////////// // Selection_lists class implementation /////////////////////////////////////////////////////////////////////////////// constructor selection_lists.create; begin entity_lists := TList.Create;; end; destructor selection_lists.destroy; begin entity_lists.Free; inherited destroy; end; procedure selection_lists.save_to_DXF_file(aname:string); var lp1,lp2 : integer; DXF : DXF_Object; layer : DXF_layer; el : Entity_List; begin DXF := DXF_Object.create(''); for lp1:=0 to entity_lists.count-1 do begin el := Entity_List(entity_lists[lp1]); el.Kludge_layer := el.parent_layer; // we need to keep track of where they came from layer := DXF.new_layer(el.parent_layer.name,true); layer.add_entity_list(el); end; DXF.save_to_file(aname); // now get the lists back from the temporary DXF object (without it deleting them) for lp1:=DXF.layer_lists.count-1 downto 0 do begin layer := DXF_Layer(DXF.layer_lists[lp1]); for lp2:=layer.entity_lists.count-1 downto 0 do layer.delete(Entity_List(layer.entity_lists[lp2]).name,FALSE); end; DXF.Free; // reset the parent layer of the entity_lists for lp1:=0 to entity_lists.count-1 do begin el := Entity_List(entity_lists[lp1]); el.parent_layer := el.Kludge_layer; // we stored them temporarily end; end; function selection_lists.find_closest_2D_point(p:Point3D; var ent:DXF_Entity) : Point3D; var lp1 : integer; dist,mind : double; entx : DXF_Entity; begin mind := 1E10; for lp1:=0 to entity_lists.count-1 do begin dist := Entity_List(entity_lists[lp1]).closest_vertex_square_distance_2D(p,entx); if distnil then begin result := entx.closest_vertex(p); ent := entx; exit; end; end; end; // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * // Generating PowerCAD source // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * function DXF_Object.GetPCPoint(P:Point3D; OCS:pMatrix): TDoublePoint; var tc : Point3D; begin try if OCS=nil then begin result.x := P.x - pcww; result.y := P.y - pcwh; end else begin tc := TransformPoint(OCS^,P); result.x := tc.x - pcww; result.y := tc.y - pcwh; end; if CadHeight > 0 then result.y := CadHeight - result.y; if CadWidth > 0 then result.x := CadWidth - result.x; except end; end; procedure DXF_Entity.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); begin end; procedure Entity_List.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer); var lp1 : integer; begin if name = 'Block_' then exit; for lp1:=0 to (entities.Count-1) do DXF_Entity(entities[lp1]).exportToPowerCAD(cad,map_fn,layerNum,nil); end; procedure DXF_Layer.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer); var lp2: integer; data_list : Entity_List; begin for lp2:=0 to num_lists-1 do begin data_list := entity_lists[lp2]; data_list.ExportToPowerCad(cad,map_fn,LayerNum); end; end; procedure DXF_Object.ExportToPowerCad(Cad: TPCDrawing;Layered,incVertex:Boolean); var Layer:DXF_Layer; DXFLayer : Integer; lp1: integer; emax,emin : Point3d; begin emax := get_max_extent; emin := get_min_extent; PCWh := ((emax.y-emin.y) / 2) - (Cad.WorkHeight / 2); PCWw := ((emax.x-emin.x) / 2) - (Cad.WorkWidth / 2); PCVertexOk := incVertex; CadHeight := 0; CadWidth := 0; if ord(Cad.VerticalZero) = 1 then CadHeight := Cad.WorkHeight; if ord(Cad.HorizontalZero) = 1 then CadWidth := Cad.WorkWidth; if not layered then begin DXFLayer := Cad.NewLayer('DXFLayer'); end; for lp1:=0 to layer_lists.count-1 do begin layer := layer_lists[lp1]; if layered then DXFLayer := Cad.NewLayer(layer.layer_name); layer.ExportToPowerCad(Cad,GetPCPoint,DXFLayer) end; if not layered then begin Cad.SelectAll(DxfLayer); Cad.GroupSelection; end; end; (* procedure Point_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var po : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; po := map_fn(p1,t_matrix); draw_cross(acanvas,po); end; procedure Line_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var pa,pb : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; pa := map_fn(p1,t_matrix); pb := map_fn(p2,t_matrix); acanvas.Moveto(pa.x,pa.y); acanvas.Lineto(pb.x,pb.y); end; procedure Text_.calcText(acanvas:TCanvas; map_fn:coord_convert; OCS:pM; t:string); var pa,dummy1,dummy2 : TPoint; Fheight : integer; begin with acanvas.Pen do if Color<>colour then Color:=colour; // kludgy method for scaling text heights dummy1 := map_fn(origin3D,nil); dummy2 := map_fn(aPoint3D(0,h,0),nil); Fheight := 2+(dummy1.y-dummy2.y); if FHeight=2 then exit; with acanvas.Font do begin if Height<>Fheight then Height := Fheight; if color<>colour then color := colour; end; case hor_align of 0 : SetTextAlign(acanvas.handle,TA_LEFT + TA_BASELINE); 1 : SetTextAlign(acanvas.handle,TA_CENTER + TA_BASELINE); 2 : SetTextAlign(acanvas.handle,TA_RIGHT + TA_BASELINE); end; pa := map_fn(align_pt,OCS_WCS); acanvas.TextOut(pa.x,pa.y,t); end; procedure Text_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); calcText(acanvas,map_fn,t_matrix,textstr); end; procedure Circle_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var pa,pb : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; pa := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pb := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); // bug in Ellipse routine causes crash if extents are too small if (pb.x>pa.x+1) and (pa.y>pb.y+1) then acanvas.Ellipse(pa.x,pa.y,pb.x,pb.y) else acanvas.pixels[pa.x,pa.y] := acanvas.Pen.Color; end; procedure Arc_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var pu,pv,pw,px : TPoint; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; pu := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pv := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); pw := map_fn(aPoint3D(p1.x+cos(angle1)*radius,p1.y+sin(angle1)*radius,p1.z+radius),t_matrix); px := map_fn(aPoint3D(p1.x+cos(angle2)*radius,p1.y+sin(angle2)*radius,p1.z+radius),t_matrix); if (pv.x>pu.x+1) and (pu.y>pv.y+1) then acanvas.Arc(pu.x,pu.y,pv.x,pv.y,pw.x,pw.y,px.x,px.y) else acanvas.pixels[pu.x,pu.y] := acanvas.Pen.Color; end; procedure Polyline_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..max_vertices_per_polyline-1] of TPoint; lp1,tn : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); if not closed then acanvas.Polyline(Slice(PointArray,numvertices)) else acanvas.Polygon(Slice(PointArray,numvertices)); end; procedure Polygon_mesh_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..max_vertices_per_polyline-1] of TPoint; tp : TPoint; lp1,lp2,inx : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); // draw the M N-length polylines - we can use the array directly if closeN then for lp1:=0 to M-1 do acanvas.Polygon( Slice(pptarray(@PointArray[N*lp1])^,N)) else for lp1:=0 to M-1 do acanvas.Polyline(Slice(pptarray(@PointArray[N*lp1])^,N)); // draw the N M-length polylines - we need to hop along the array in M steps for lp1:=0 to N-1 do begin acanvas.MoveTo(PointArray[lp1].x,PointArray[lp1].y); for lp2:=1 to M-1 do begin tp := PointArray[lp2*N+lp1]; acanvas.LineTo(tp.x,tp.y); end; if closeM then acanvas.LineTo(PointArray[lp1].x,PointArray[lp1].y); end; end; procedure Polyface_mesh_.Draw(acanvas:TCanvas; map_fn:coord_convert; OCS:pM); var PointArray : array[0..3] of TPoint; lp1,lp2,inx : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); with acanvas.Pen do if Color<>colour then Color:=colour; for lp1:=0 to numfaces-1 do begin for lp2:=0 to 3 do begin inx := facelist^[lp1].nf[lp2]; if inx<0 then break; // index -> -1 = end of vertices PointArray[lp2] := map_fn(polypoints^[inx],t_matrix); end; acanvas.Polygon(Slice(PointArray,lp2)); end; end; *) procedure Point_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var po: TDoublePoint; t_matrix : pMatrix; begin //inherited; t_matrix := update_transformations(OCS_WCS,OCS); po := map_fn(p1,t_matrix); if PCVertexOk then Cad.Vertex(LayerNum,po.x,po.y,False); end; procedure Line_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var po1,po2: TDoublePoint; t_matrix : pMatrix; begin //inherited; t_matrix := update_transformations(OCS_WCS,OCS); po1 := map_fn(p1,t_matrix); po2 := map_fn(p2,t_matrix); Cad.Line(LayerNum,po1.x,po1.y,po2.x,po2.y,1,0,colour,0,False); end; procedure Text_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var pa : TDoublePoint; Fheight: Double; t_matrix : pMatrix; ratio: double; begin t_matrix := update_transformations(OCS_WCS,OCS); Fheight := h; ratio := 0; //case hor_align of // 0 : SetTextAlign(acanvas.handle,TA_LEFT + TA_BASELINE); // 1 : SetTextAlign(acanvas.handle,TA_CENTER + TA_BASELINE); // 2 : SetTextAlign(acanvas.handle,TA_RIGHT + TA_BASELINE); //end; pa := map_fn(align_pt,OCS_WCS); cad.TextOut(layernum,pa.x,pa.y,0,fHeight,ratio,textstr,'Arial',0,colour,False); end; procedure Attrib_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var pa : TDoublePoint; Fheight : Double; t_matrix : pMatrix; ratio: double; begin t_matrix := update_transformations(OCS_WCS,OCS); if not visible then exit; Fheight := h; ratio := 0; //case hor_align of // 0 : SetTextAlign(acanvas.handle,TA_LEFT + TA_BASELINE); // 1 : SetTextAlign(acanvas.handle,TA_CENTER + TA_BASELINE); // 2 : SetTextAlign(acanvas.handle,TA_RIGHT + TA_BASELINE); //end; pa := map_fn(align_pt,OCS_WCS); cad.TextOut(layernum,pa.x,pa.y,0,fHeight,ratio,tagstr,'Arial',0,colour,False); end; procedure Arc_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var pu,pv,pw,px : TDoublePoint; po,pa,pb : TDoublePoint; t_matrix: pMatrix; rad : Double; cx,cy: Double; ta,a1,a2: Double; begin //inherited; t_matrix := update_transformations(OCS_WCS,OCS); pu := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pv := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); pw := map_fn(aPoint3D(p1.x+cos(angle1)*radius,p1.y+sin(angle1)*radius,p1.z+radius),t_matrix); px := map_fn(aPoint3D(p1.x+cos(angle2)*radius,p1.y+sin(angle2)*radius,p1.z+radius),t_matrix); rad := radius; cx := (pu.x + pv.x) / 2; cy := (pu.y + pv.y) / 2; a1 := angle1; a2 := angle2; if ord(Cad.VerticalZero) = 1 then begin a1 := 2*pi - a1; a2 := 2*pi - a2; ta := a1; a1 := a2; a2 := ta; end; if ord(Cad.HorizontalZero) = 1 then begin a1 := pi - a1; a2 := pi - a2; ta := a1; a1 := a2; a2 := ta; end; Cad.Arc(LayerNum,cx,cy,rad,a1,a2,1,ord(psSolid),colour,ord(bsClear),0,0,false); end; procedure Polyline_.ExportToPowerCad(Cad: TPCDrawing;map_fn: PC_convert;LayerNum:integer;OCS:pM); var PointArray : TDoublePointArr; lp1,tn : integer; t_matrix : pMatrix; begin //inherited; SetLength(PointArray,numvertices); t_matrix := update_transformations(OCS_WCS,OCS); for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); cad.PolyLine(layernum,PointArray,1,ord(psSolid),colour,0,ord(bsClear),0,closed,false); end; procedure Insert_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var lp1 : integer; t_matrix : pMatrix; TempMatrix : Matrix; begin //inherited; // we mustn't use the update_transformations call because inserts may be // nested inside blocks inside other blocks, and update_transformations uses // a temp fixed matrix which will be overwritten. if OCS=nil then t_matrix := OCS_WCS else if OCS_WCS=nil then t_matrix := OCS else begin TempMatrix := MatrixMultiply(OCS_WCS^,OCS^); t_matrix := @TempMatrix; end; //for lp1:=0 to num_attribs-1 do attribs[lp1].Draw(acanvas,map_fn,t_matrix); //if blockname<>'' then block.Draw(acanvas,map_fn,t_matrix); for lp1:=0 to num_attribs-1 do attribs[lp1].ExportToPowerCad(cad,map_fn,LayerNum,t_matrix); if blockname<>'' then block.ExportToPowerCad(cad,map_fn,LayerNum,t_matrix); end; procedure Circle_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var po,pa,pb:TDoublePoint; rad:Double; t_matrix : pMatrix; cx,cy: Double; begin //inherited; t_matrix := update_transformations(OCS_WCS,OCS); pa := map_fn(aPoint3D(p1.x-radius,p1.y-radius,p1.z-radius),t_matrix); pb := map_fn(aPoint3D(p1.x+radius,p1.y+radius,p1.z+radius),t_matrix); po := map_fn(p1,t_matrix); rad := radius; cad.Circle(layernum,po.x,po.y,rad,1,ord(psSolid),colour,ord(bsClear),0,false) end; procedure Block_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var lp1 : integer; t_matrix : pMatrix; TempMatrix : Matrix; begin // we mustn't use the update_transformations call because blocks may be // nested inside blocks inside other blocks, and update_transformations uses // a temp fixed matrix which will be overwritten. if OCS=nil then t_matrix := OCS_WCS else if OCS_WCS=nil then t_matrix := OCS else begin TempMatrix := MatrixMultiply(OCS_WCS^,OCS^); t_matrix := @TempMatrix; end; for lp1:=0 to entities.count-1 do DXF_Entity(entities[lp1]).ExportToPowerCAd(cad,map_fn,LayerNum,t_matrix); end; procedure Polygon_mesh_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var PointArray : TDoublePointArr; tPointS : TDoublePointArr; tp : TPoint; lp1,lp2,inx,i : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); SetLength(PointArray,numvertices); for lp1:=0 to numvertices-1 do PointArray[lp1] := map_fn(polypoints^[lp1],t_matrix); // draw the M N-length polylines - we can use the array directly SetLength(tPoints,N); for lp1:=0 to M-1 do begin for i := 0 to n-1 do tPoints[i] := PointArray[n*lp1+i]; cad.PolyLine(layernum,tPoints,1,ord(psSolid),colour,0,ord(bsClear),0,CloseN,false); end; Setlength(tPoints,M); for lp1:=0 to N-1 do begin tPoints[0] := PointArray[lp1]; for lp2:=1 to M-1 do begin tPoints[lp2] := PointArray[lp2*N+lp1]; end; cad.PolyLine(layernum,tPoints,1,ord(psSolid),colour,0,ord(bsClear),0,CLoseM,false); end; end; procedure Polyface_mesh_.ExportToPowerCad(Cad: TPCDrawing; map_fn: PC_convert;LayerNum:integer;OCS:pM); var PointArray : TDoublePointArr; lp1,lp2,inx : integer; t_matrix : pMatrix; begin t_matrix := update_transformations(OCS_WCS,OCS); for lp1:=0 to numfaces-1 do begin for lp2 := 0 to 3 do begin inx := facelist^[lp1].nf[lp2]; if inx<0 then break; SetLength(PointArray,lp2+1); PointArray[lp2] := map_fn(polypoints^[inx],t_matrix); end; cad.Polygon(layernum,PointArray,1,ord(psSolid),colour,ord(bsClear),0,false); end; end; initialization entities_in_existence := 0; Ent_lists_in_existence := 0; layers_in_existence := 0; DXF_Obj_in_existence := 0; end.