-
Notifications
You must be signed in to change notification settings - Fork 1
/
SimWorld.pas
2371 lines (2115 loc) · 74.8 KB
/
SimWorld.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
unit SimWorld;
interface
uses Windows, Classes, Graphics, Forms, Extctrls, SimTools, Controls, TypInfo;
type
TPercent = 0..100;
TSimWorld = class;
TComposition =
record
Nutritious: TPercent;
Innocuous: TPercent;
Toxic: TPercent;
end;
TMatter =
class
private
FComposition: TComposition;
FSmell: longint;
procedure SetComposition(const Value: TComposition);
procedure ComputeSmell;
public
property Composition: TComposition read FComposition write SetComposition;
property Smell: longint read FSmell;
end;
TPosition =
record
X: Longint; Y: Longint; end;
TSize =
record
Width: longint; Height: longint;
end;
TSimObject =
class(TMatter)
private
FSurmountable: boolean;
procedure SetSurmountable(const Value: boolean);
procedure SetBitmap(const index: integer; Bitmap: TBitmap);
public
Position: TPosition;
Size: TSize;
Image: TMosaic;
World: TSimWorld;
constructor Create(const X, Y, W, H: longint; aWorld: TSimWorld; anImage: TMosaic = nil);
destructor Destroy; override;
property Surmountable: boolean read FSurmountable write SetSurmountable;
procedure SetImage(const ImageID: integer);
end;
TBrick =
class(TSimObject)
public
constructor Create(const X, Y, W, H: longint; aWorld: TSimWorld; anImage: TMosaic = nil);
end;
CQuarry = class of TQuarry;
TQuarry =
class(TSimObject)
private
FCapacity: longint;
FQuarryType: integer;
StartCapacity: longint;
procedure SetCapacity(const Value: longint);
function GetCapacityPercent: TPercent;
public
constructor Create(const X, Y, W, H, aStartCap: longint; aWorld: TSimWorld; anImage: TMosaic = nil); virtual;
property Capacity: longint read FCapacity write SetCapacity;
property CapacityPercent: TPercent read GetCapacityPercent;
property QuarryType: integer read FQuarryType;
procedure CheckSate;
end;
TYellowQuarry =
class(TQuarry)
public
constructor Create(const X, Y, W, H, aStartCap: longint; aWorld: TSimWorld; anImage: TMosaic = nil); override;
end;
TRedQuarry =
class(TQuarry)
public
constructor Create(const X, Y, W, H, aStartCap: longint; aWorld: TSimWorld; anImage: TMosaic = nil); override;
end;
TGreenQuarry =
class(TQuarry)
public
constructor Create(const X, Y, W, H, aStartCap: longint; aWorld: TSimWorld; anImage: TMosaic = nil); override;
end;
TBlueQuarry =
class(TQuarry)
public
constructor Create(const X, Y, W, H, aStartCap: longint; aWorld: TSimWorld; anImage: TMosaic = nil); override;
end;
TACreature = class;
TSingleDir = -1..1;
TSpaceDir =
record
X: TSingleDir;
Y: TSingleDir;
end;
TAngle = (anRight, anLeft);
TSegment =
class(TSimObject)
private
FACreature: TACreature;
FNext: TSegment;
FPrevious: TSegment;
procedure SetLeft(const Value: integer);
procedure SetTop(const Value: integer);
function GetBottom: integer;
function GetRight: integer;
procedure SetWidth(const Value: integer);
procedure SetACreature(const Value: TACreature);
procedure OnClick(Sender: TObject);
function GetLeft: integer;
function GetTop: integer;
function GetWidth: integer;
procedure SetNext(const Value: TSegment);
function GetCenterX: integer;
function GetCenterY: integer;
procedure SetCenterX(const Value: integer);
procedure SetCenterY(const Value: integer);
procedure SetPrev(const Value: TSegment);
public
property Left: integer read GetLeft write SetLeft;
property Top: integer read GetTop write SetTop;
property Width: integer read GetWidth write SetWidth;
property Right: integer read GetRight;
property Bottom: integer read GetBottom;
property ACreature: TACreature read FACreature write SetACreature;
property Next: TSegment read FNext write SetNext;
property Previous: TSegment read FPrevious write SetPrev;
property CenterX: integer read GetCenterX write SetCenterX;
property CenterY: integer read GetCenterY write SetCenterY;
public
constructor Create(aACreature: TACreature; Previous: TSegment; anImage: TMosaic = nil;
const X: longint = 0; const Y: longint = 0; const W: longint = 0);
procedure MoveSegment(const Step: integer);
end;
TNervousSys =
class
private
Owner: TACreature;
public
constructor Create(aOwner: TACreature);
procedure Performance;
end;
TDigestiveSys =
class
private
Owner: TACreature;
FBiteSize: integer;
FStomachCapacity: integer;
FDrainCapacity: integer;
FPoisonousCapacity: integer;
procedure SetBiteSize(const Value: integer);
procedure SetStomachCapacity(const Value: integer);
procedure SetDrainCapacity(const Value: integer);
procedure SetPoisonousCapacity(const Value: integer);
public
constructor Create(aOwner: TACreature);
procedure Performance;
function Bite: boolean;
function CanEat: boolean;
property BiteSize: integer read FBiteSize write SetBiteSize;
property StomachCapacity: integer read FStomachCapacity write SetStomachCapacity;
property DrainCapacity: integer read FDrainCapacity write SetDrainCapacity;
property PoisonousCapacity: integer read FPoisonousCapacity write SetPoisonousCapacity;
end;
{$TYPEINFO ON}
TTypeValue = (tvUnknown, tvInteger, tvFloat);
TGenes =
class
private
PropList: PPropList;
FFertilityHealth: longint;
FIncubationTime: longint;
function GetGenesCount: integer;
function GetIntValue(const index: integer): longint;
procedure SetIntValue(const index: integer; const Value: longint);
function GetFloatValue(const index: integer): single;
procedure SetFloatValue(const index: integer; const Value: single);
function GetTypeValue(const index: integer): TTypeValue;
function MutateFlt(const BaseGen: single): single;
function MutateOrd(const BaseGen: Integer): longint;
function GetGenName(const index: integer): ShortString;
procedure SetFertilityHealth(const Value: longint);
procedure SetIncubationTime(const Value: longint);
public
constructor Create;
constructor DefaultGenes;
destructor Destroy; override;
function CopyGenes: TGenes;
function CombineGenes(aGenes: TGenes): TGenes;
property GenesCount: integer read GetGenesCount;
property IntValue[const index: integer]: longint read GetIntValue write SetIntValue;
property FloatValue[const index: integer]: single read GetFloatValue write SetFloatValue;
property TypeValue[const index: integer]: TTypeValue read GetTypeValue;
property GenName[const index: integer]: ShortString read GetGenName;
private
FMutateRate: longint;
FDeltaOrdMutate: longint;
FDeltaFltMutate: single;
FFirstLibidoSlope: longint;
FThirdRecoverAmount: longint;
FEndStamping: longint;
FPartitionRate: longint;
FFirstHealthLibidoPoint: longint;
FHealthFatten: longint;
FRipeLibido: longint;
FThirdLibidoSlope: longint;
FFirstRecoverAmount: longint;
FFirstHealthSlope: longint;
FSecondRecoverAmount: longint;
FFattenRate: longint;
FPoisonousCapacity: longint;
FFourthHungerSlope: longint;
FSecondHealthSlope: longint;
FSecondLibidoSlope: longint;
FGrowthRate: longint;
FBeginStamping: longint;
FSecondHungerSlope: longint;
FHealthGrowth: longint;
FStartBodyWidth: longint;
FFattenAmount: longint;
FRestRatio: longint;
FFirstRecoverPoint: longint;
FReliefIntersectRatio: single;
FLibidoAfterBudding: longint;
FFirstHungerSlope: longint;
FStartImmunologicalStrength: longint;
FThirdHungerSlope: longint;
FLibidoAfterBipartition: longint;
FLongStep: longint;
FHungerToBite: longint;
FStartBiteSize: longint;
FSecondRecoverPoint: longint;
FWalkRatio: longint;
FStomachCapacity: longint;
FDrainCapacity: longint;
FSecondHealthLibidoPoint: longint;
FTurnRatio: longint;
FThirdHealthSlope: longint;
FAbortAngle: single;
FDeflectAngle: single;
FIntersectRatio: single;
procedure SetMutateRate(const Value: longint);
procedure SetDeltaOrdMutate(const Value: longint);
procedure SetDeltaFltMutate(const Value: single);
procedure SetAbortAngle(const Value: single);
procedure SetBeginStamping(const Value: longint);
procedure SetDeflectAngle(const Value: single);
procedure SetDrainCapacity(const Value: longint);
procedure SetEndStamping(const Value: longint);
procedure SetFattenAmount(const Value: longint);
procedure SetFattenRate(const Value: longint);
procedure SetFirstHealthLibidoPoint(const Value: longint);
procedure SetFirstHealthSlope(const Value: longint);
procedure SetFirstHungerSlope(const Value: longint);
procedure SetFirstLibidoSlope(const Value: longint);
procedure SetFirstRecoverAmount(const Value: longint);
procedure SetFirstRecoverPoint(const Value: longint);
procedure SetFourthHungerSlope(const Value: longint);
procedure SetGrowthRate(const Value: longint);
procedure SetHealthFatten(const Value: longint);
procedure SetHealthGrowth(const Value: longint);
procedure SetHungerToBite(const Value: longint);
procedure SetIntersectRatio(const Value: single);
procedure SetLibidoAfterBipartition(const Value: longint);
procedure SetLibidoAfterBudding(const Value: longint);
procedure SetLongStep(const Value: longint);
procedure SetPartitionRate(const Value: longint);
procedure SetPoisonousCapacity(const Value: longint);
procedure SetReliefIntersectRatio(const Value: single);
procedure SetRestRatio(const Value: longint);
procedure SetRipeLibido(const Value: longint);
procedure SetSecondHealthLibidoPoint(const Value: longint);
procedure SetSecondHealthSlope(const Value: longint);
procedure SetSecondHungerSlope(const Value: longint);
procedure SetSecondLibidoSlope(const Value: longint);
procedure SetSecondRecoverAmount(const Value: longint);
procedure SetSecondRecoverPoint(const Value: longint);
procedure SetStartBiteSize(const Value: longint);
procedure SetStartBodyWidth(const Value: longint);
procedure SetStartImmunologicalStrength(const Value: longint);
procedure SetStomachCapacity(const Value: longint);
procedure SetThirdHealthSlope(const Value: longint);
procedure SetThirdHungerSlope(const Value: longint);
procedure SetThirdLibidoSlope(const Value: longint);
procedure SetThirdRecoverAmount(const Value: longint);
procedure SetTurnRatio(const Value: longint);
procedure SetWalkRatio(const Value: longint);
published
// Genetic System
property MutateRate : longint read FMutateRate write SetMutateRate;
property DeltaOrdMutate : longint read FDeltaOrdMutate write SetDeltaOrdMutate;
property DeltaFltMutate : single read FDeltaFltMutate write SetDeltaFltMutate;
// Motor System
property DeflectAngle : single read FDeflectAngle write SetDeflectAngle;
property AbortAngle : single read FAbortAngle write SetAbortAngle;
property IntersectRatio : single read FIntersectRatio write SetIntersectRatio;
property ReliefIntersectRatio : single read FReliefIntersectRatio write SetReliefIntersectRatio;
property LongStep : longint read FLongStep write SetLongStep;
property EndStamping : longint read FEndStamping write SetEndStamping;
property BeginStamping : longint read FBeginStamping write SetBeginStamping;
property TurnRatio : longint read FTurnRatio write SetTurnRatio;
property WalkRatio : longint read FWalkRatio write SetWalkRatio;
property RestRatio : longint read FRestRatio write SetRestRatio;
// Metabolism
property FirstHealthSlope : longint read FFirstHealthSlope write SetFirstHealthSlope;
property SecondHealthSlope : longint read FSecondHealthSlope write SetSecondHealthSlope;
property ThirdHealthSlope : longint read FThirdHealthSlope write SetThirdHealthSlope;
property FirstHungerSlope : longint read FFirstHungerSlope write SetFirstHungerSlope;
property SecondHungerSlope : longint read FSecondHungerSlope write SetSecondHungerSlope;
property ThirdHungerSlope : longint read FThirdHungerSlope write SetThirdHungerSlope;
property FourthHungerSlope : longint read FFourthHungerSlope write SetFourthHungerSlope;
property FirstLibidoSlope : longint read FFirstLibidoSlope write SetFirstLibidoSlope;
property SecondLibidoSlope : longint read FSecondLibidoSlope write SetSecondLibidoSlope;
property ThirdLibidoSlope : longint read FThirdLibidoSlope write SetThirdLibidoSlope;
// Reproducer System
property PartitionRate : longint read FPartitionRate write SetPartitionRate;
property LibidoAfterBipartition : longint read FLibidoAfterBipartition write SetLibidoAfterBipartition;
property LibidoAfterBudding : longint read FLibidoAfterBudding write SetLibidoAfterBudding;
property LibidoAfterSex : longint read FLibidoAfterBudding write SetLibidoAfterBudding;
property RipeLibido : longint read FRipeLibido write SetRipeLibido;
property FirstHealthLibidoPoint : longint read FFirstHealthLibidoPoint write SetFirstHealthLibidoPoint;
property SecondHealthLibidoPoint : longint read FSecondHealthLibidoPoint write SetSecondHealthLibidoPoint;
property FertilityHealth : longint read FFertilityHealth write SetFertilityHealth;
property IncubationTime : longint read FIncubationTime write SetIncubationTime;
// Digestive System
property StartBiteSize : longint read FStartBiteSize write SetStartBiteSize;
property HungerToBite : longint read FHungerToBite write SetHungerToBite;
property StomachCapacity : longint read FStomachCapacity write SetStomachCapacity;
property DrainCapacity : longint read FDrainCapacity write SetDrainCapacity;
property PoisonousCapacity : longint read FPoisonousCapacity write SetPoisonousCapacity;
// Immunological System
property StartImmunologicalStrength : longint read FStartImmunologicalStrength write SetStartImmunologicalStrength;
property FirstRecoverPoint : longint read FFirstRecoverPoint write SetFirstRecoverPoint;
property FirstRecoverAmount : longint read FFirstRecoverAmount write SetFirstRecoverAmount;
property SecondRecoverPoint : longint read FSecondRecoverPoint write SetSecondRecoverPoint;
property SecondRecoverAmount : longint read FSecondRecoverAmount write SetSecondRecoverAmount;
property ThirdRecoverAmount : longint read FThirdRecoverAmount write SetThirdRecoverAmount;
// Growth System
property StartBodyWidth : longint read FStartBodyWidth write SetStartBodyWidth;
property FattenRate : longint read FFattenRate write SetFattenRate;
property HealthFatten : longint read FHealthFatten write SetHealthFatten;
property FattenAmount : longint read FFattenAmount write SetFattenAmount;
property GrowthRate : longint read FGrowthRate write SetGrowthRate;
property HealthGrowth : longint read FHealthGrowth write SetHealthGrowth;
end;
{$TYPEINFO OFF}
TReproducerSys =
class
private
Owner: TACreature;
FIncubationTime: integer;
FFertilityHealth: integer;
FPregnancy: boolean;
FEmbryoGenoma: TGenes;
FLibidoAfterSex: longint;
PregnancyTime: integer;
procedure Spawn;
procedure SetIncubationTime(const Value: integer);
procedure SetFertilityHealth(const Value: integer);
procedure SetPregnancy(const Value: boolean);
procedure SetEmbryoGenoma(const Value: TGenes);
procedure SetLibidoAfterSex(const Value: longint);
public
constructor Create(aOwner: TACreature);
procedure Performance;
procedure MakeSex;
procedure Bipartition;
procedure Budding;
function Fertilize: boolean;
procedure Inseminate(aGenes: TGenes);
property IncubationTime: integer read FIncubationTime write SetIncubationTime;
property FertilityHealth: integer read FFertilityHealth write SetFertilityHealth;
property Pregnancy: boolean read FPregnancy write SetPregnancy;
property EmbryoGenoma: TGenes read FEmbryoGenoma write SetEmbryoGenoma;
property LibidoAfterSex: longint read FLibidoAfterSex write SetLibidoAfterSex;
end;
TImmunologicalSys =
class
private
Owner: TACreature;
FImmunologicalStrength: integer;
procedure Recover(const Rate: longint);
procedure SetImmunologicalStrength(const Value: integer);
public
constructor Create(aOwner: TACreature);
procedure Performance;
property ImmunologicalStrength: integer read FImmunologicalStrength write SetImmunologicalStrength;
end;
TMotorSys =
class
private
Owner: TACreature;
public
constructor Create(aOwner: TACreature);
procedure Performance;
function MoveAhead(const Speed: integer): boolean;
procedure TurnHead(const Angle: TAngle);
end;
TGrowthSys =
class
private
Owner: TACreature;
public
constructor Create(aOwner: TACreature);
procedure Performance;
end;
TMetabolism =
class
private
Owner: TACreature;
FEnergy: longint;
FHealth: longint;
FMaxLiveTime: longint;
FTimeLived: longint;
FOldnessRate: longint;
FLibido: longint;
FHunger: longint;
procedure SetEnergy(const Value: longint);
procedure SetHealth(const Value: longint);
procedure SetMaxLiveTime(const Value: longint);
procedure SetTimeLived(const Value: longint);
procedure SetOldnessRate(const Value: longint);
procedure SetHunger(const Value: longint);
procedure SetLibido(const Value: longint);
function GetEnergyPercent: longint;
function GetHealthPercent: longint;
function GetHungerPercent: longint;
function GetLibidoPercent: longint;
function GetTimeLivedPercent: longint;
public
procedure Performance;
property EnergyPercent: longint read GetEnergyPercent;
property HealthPercent: longint read GetHealthPercent;
property HungerPercent: longint read GetHungerPercent;
property LibidoPercent: longint read GetLibidoPercent;
property TimeLivedPercent: longint read GetTimeLivedPercent;
public
property Energy: longint read FEnergy write SetEnergy;
property Health: longint read FHealth write SetHealth;
property Hunger: longint read FHunger write SetHunger;
property Libido: longint read FLibido write SetLibido;
property MaxLiveTime: longint read FMaxLiveTime write SetMaxLiveTime;
property TimeLived: longint read FTimeLived write SetTimeLived;
property OldnessRate: longint read FOldnessRate write SetOldnessRate;
constructor Create(aOwner: TACreature);
destructor Destroy; override;
end;
TSimWorld =
class
private
WorldObjects: TList;
FCreatures: TList;
FOnACreatureClick: TNotifyEvent;
Timer: TTimer;
FOnNewACreature: TNotifyEvent;
FOnLostACreature: TNotifyEvent;
procedure SetOnACreatureClick(const Value: TNotifyEvent);
procedure OnTimer(Sender: TObject);
procedure SetOnLostACreature(const Value: TNotifyEvent);
procedure SetOnNewACreature(const Value: TNotifyEvent);
function GetCreature(const i: integer): TACreature;
function GetCreatureCount: integer;
function GetTimeSpeed: integer;
procedure SetTimeSpeed(const Value: integer);
private
FBGColor: TColor;
procedure SetBGColor(const Value: TColor);
public
updating: boolean;
constructor Create(Form: TForm; TheImages: TImageList);
destructor Destroy; override;
procedure AddBrick(const X, Y, Width, Height: Integer; aWall: TWall = nil); overload;
procedure AddBrick(aWall: TWall); overload;
procedure AddQuarry(Kind: CQuarry; const X, Y, Width, Height, StartCap: Integer; aSubstratum: TSubstratum = nil); overload;
procedure AddQuarry(aSubstratum: TSubstratum); overload;
procedure AddACreature(const Name: string; const X, Y: Integer; aCreature: TCreature = nil); overload;
procedure AddACreature(aCreature: TCreature); overload;
procedure AddObject(aControl: TControl);
function QuarryAt(const X, Y: longint): TQuarry;
function ACreatureClose(C: TACreature): TACreature;
function Bump(const X1, Y1, X2, Y2: longint; CO: TSimObject): boolean;
procedure Stop;
procedure Resume;
procedure Trace;
procedure InsertACreature(C: TACreature);
public
Ground: TForm;
Images: TImageList;
property BGColor: TColor read FBGColor write SetBGColor;
property OnACreatureClick: TNotifyEvent read FOnACreatureClick write SetOnACreatureClick;
property OnLostACreature: TNotifyEvent read FOnLostACreature write SetOnLostACreature;
property OnNewACreature: TNotifyEvent read FOnNewACreature write SetOnNewACreature;
property Creature[const i: integer]: TACreature read GetCreature;
property CreatureCount: integer read GetCreatureCount;
property TimeSpeed: integer read GetTimeSpeed write SetTimeSpeed;
end;
TACreature =
class
private
FName: string;
FOnClick: TNotifyEvent;
Body: TList;
FIntersectRatio: real;
FParenthood: integer;
procedure SetBodyWidth(const Value: integer);
function GetTailBottom: integer;
function GetTailLeft: integer;
procedure SetName(const Value: string);
procedure SetOnClick(const Value: TNotifyEvent);
function GetAlive: boolean;
function GetHead: TSegment;
function GetTail: TSegment;
function GetSegment(const i: integer): TSegment;
function GetSegmentCount: integer;
procedure Living;
procedure SetIntersectRatio(const Value: real);
procedure SetParenthood(const Value: integer);
function GetBodyWidth: integer;
public
World: TSimWorld;
Genes: TGenes;
Metabolism: TMetabolism;
DigestiveSys: TDigestiveSys;
ImmunologicalSys: TImmunologicalSys;
MotorSys: TMotorSys;
GrowthSys: TGrowthSys;
ReproducerSys: TReproducerSys;
NervousSys: TNervousSys;
Direction: TSpaceDir;
public
procedure AddSegment(anImage: TMosaic = nil);
procedure TurnHead(const X, Y: longint);
procedure UpDateFace;
function MoveHead(const Step: integer): boolean;
function Intersect(const X1, Y1, X2, Y2: longint; Obj: TSimObject): boolean;
constructor Create(const aName: string; G: TGenes; const X, Y: Integer; aWorld: TSimWorld; ImplicitSeg: boolean; anImage: TMosaic = nil);
destructor Destroy; override;
property BodyWidth: integer read GetBodyWidth write SetBodyWidth;
property TailLeft: integer read GetTailLeft;
property TailBottom: integer read GetTailBottom;
property Name: string read FName write SetName;
property OnClick: TNotifyEvent read FOnClick write SetOnClick;
property Alive: boolean read GetAlive;
property Head: TSegment read GetHead;
property Tail: TSegment read GetTail;
property Segment[const i: integer]: TSegment read GetSegment;
property SegmentCount: integer read GetSegmentCount;
property IntersectRatio: real read FIntersectRatio write SetIntersectRatio;
property Parenthood: integer read FParenthood write SetParenthood;
end;
const
HIGHTSPEED = 100000;
MIDSPEED = 10000;
LOWSPEED = 1000;
SPEED = LOWSPEED;
MAXLONGINT = 2147483647;
TOPVALUE = MAXLONGINT div SPEED;
FIRST_OLDNESS_RATE = 100;
LOW_SPENDING = 10;
MID_SPENDING = 100;
HIGHT_SPENDING = 1000;
HUGE_SPENDING = 10000;
MAXENERGY = TOPVALUE;
MAXHEALTH = TOPVALUE;
MAXHUNGER = TOPVALUE;
MAXLIBIDO = TOPVALUE;
MAXTIMELIVED = TOPVALUE;
QUARRY_BASE_CAPACITY = 5000;
CALORIC_RATE = 1000;
HEALING_RATE = 1;
TIME_SPEED_HIGHT = 10;
TIME_SPEED_MID = 50;
TIME_SPEED_LOW = 100;
implementation
uses SysUtils, Constants;
{ TMatter }
procedure TMatter.SetComposition(const Value: TComposition);
begin
FComposition := Value;
ComputeSmell;
end;
procedure TMatter.ComputeSmell;
begin
with FComposition do
FSmell := Longint(Nutritious) + (Longint(Innocuous) shl 8) + (Longint(Toxic) shl 16);
end;
{ TSimWorld }
procedure TSimWorld.AddBrick(const X, Y, Width, Height: Integer; aWall: TWall = nil);
var
Brick: TBrick;
begin
Brick := TBrick.Create(X, Y, Width, Height, Self, aWall);
WorldObjects.Add(Brick);
Brick.Image.Parent := Ground;
end;
procedure TSimWorld.AddBrick(aWall: TWall);
begin
with aWall do
AddBrick(Left, Top, Width, Height, aWall);
end;
procedure TSimWorld.AddQuarry(Kind: CQuarry; const X, Y, Width, Height, StartCap: Integer; aSubstratum: TSubstratum = nil);
var
Quarry: TQuarry;
begin
Quarry := Kind.Create(X, Y, Width, Height, StartCap, Self, aSubstratum);
WorldObjects.Add(Quarry);
Quarry.Image.Parent := Ground;
end;
procedure TSimWorld.AddQuarry(aSubstratum: TSubstratum);
var
QuarryKind: CQuarry;
begin
case aSubstratum.Kind of
skRed: QuarryKind := TRedQuarry;
skGreen: QuarryKind := TGreenQuarry;
skBlue: QuarryKind := TBlueQuarry;
else QuarryKind := TYellowQuarry;
end;
with aSubstratum do
AddQuarry(QuarryKind, Left, Top, Width, Height, Capacity, aSubstratum);
end;
procedure TSimWorld.AddACreature(const Name: string; const X, Y: Integer; aCreature: TCreature = nil);
begin
InsertACreature(TACreature.Create(Name, nil, X, Y, Self, true, aCreature));
end;
procedure TSimWorld.AddACreature(aCreature: TCreature);
begin
with aCreature do
AddACreature(Name, Left, Top, aCreature);
end;
procedure TSimWorld.AddObject(aControl: TControl);
begin
if aControl is TWall then AddBrick(aControl as TWall);
if aControl is TSubstratum then AddQuarry(aControl as TSubstratum);
if aControl is TCreature then AddACreature(aControl as TCreature);
end;
function TSimWorld.Bump(const X1, Y1, X2, Y2: Integer; CO: TSimObject): boolean;
var
i: integer;
R: TRect;
Obj: TSimObject;
begin
i := 0;
Result := false;
while (i < WorldObjects.Count) and not Result do
begin
Obj := WorldObjects.Items[i];
Result := not Obj.Surmountable and IntersectRect(R,
Bounds(Obj.Position.X, Obj.Position.Y, Obj.Size.Width, Obj.Size.Height),
Rect(X1, Y1, X2, Y2));
inc(i);
end;
i := 0;
if not Result
then
while (i < FCreatures.Count) and not Result do
begin
Result := TACreature(FCreatures.Items[i]).Intersect(X1, Y1, X2, Y2, CO);
inc(i);
end;
end;
constructor TSimWorld.Create(Form: TForm; TheImages: TImageList);
begin
inherited Create;
Ground := Form;
Images := TheImages;
WorldObjects := TList.Create;
FCreatures := TList.Create;
Timer := TTimer.Create(Ground);
Timer.OnTimer := OnTimer;
Timer.Interval := TIME_SPEED_MID;
end;
destructor TSimWorld.Destroy;
begin
FCreatures.free;
WorldObjects.free;
Timer.free;
inherited;
end;
procedure TSimWorld.InsertACreature(C: TACreature);
begin
WorldObjects.Add(C);
FCreatures.Add(C);
C.FOnClick := OnACreatureClick;
if Assigned(FOnNewACreature)
then OnNewACreature(C);
end;
procedure TSimWorld.OnTimer(Sender: TObject);
var
i: integer;
ACreature: TACreature;
Quarry: TQuarry;
begin
if updating then exit;
updating := true;
i := 0;
while i < WorldObjects.Count do
begin
if TObject(WorldObjects.Items[i]) is TQuarry
then
begin
Quarry := WorldObjects.Items[i];
Quarry.CheckSate;
if Quarry.Capacity = 0
then
begin
WorldObjects.Remove(Quarry);
Quarry.free;
end
else inc(i);
end
else inc(i);
end;
i := 0;
while i < FCreatures.Count do
begin
ACreature := TACreature(FCreatures.Items[i]);
with ACreature do
if not Alive
then
begin
FCreatures.Remove(ACreature);
WorldObjects.Remove(ACreature);
OnLostACreature(ACreature);
free;
end
else inc(i);
end;
for i := 0 to pred(CreatureCount) do
Creature[i].Living;
updating := false;
end;
function TSimWorld.ACreatureClose(C: TACreature): TACreature;
var
i: integer;
R: TRect;
begin
i := 0;
Result := nil;
while (i < CreatureCount) and (Result = nil) do
begin
with Creature[i].Head do
if IntersectRect(R,
Bounds(Left, Top, Width, Width),
Bounds(C.Head.Left, C.Head.Top, C.Head.Width, C.Head.Width))
then Result := Creature[i];
inc(i);
end;
end;
function TSimWorld.QuarryAt(const X, Y: longint): TQuarry;
var
i: integer;
begin
i := 0;
Result := nil;
while (i < WorldObjects.Count) and (Result = nil) do
begin
if TObject(WorldObjects.Items[i]) is TQuarry
then
with TQuarry(WorldObjects.Items[i]) do
if PtInRect(Rect(Position.X, Position.Y,
Position.X + Size.Width, Position.Y + Size.Height),
Point(X, Y))
then Result := WorldObjects.Items[i];
inc(i);
end;
end;
procedure TSimWorld.Resume;
begin
Timer.Enabled := true;
end;
procedure TSimWorld.SetBGColor(const Value: TColor);
begin
FBGColor := Value;
Ground.Color := Value;
end;
procedure TSimWorld.SetOnACreatureClick(const Value: TNotifyEvent);
begin
FOnACreatureClick := Value;
end;
procedure TSimWorld.Stop;
begin
Timer.Enabled := false;
end;
procedure TSimWorld.Trace;
begin
OnTimer(Self);
end;
procedure TSimWorld.SetOnLostACreature(const Value: TNotifyEvent);
begin
FOnLostACreature := Value;
end;
procedure TSimWorld.SetOnNewACreature(const Value: TNotifyEvent);
begin
FOnNewACreature := Value;
end;
function TSimWorld.GetCreature(const i: integer): TACreature;
begin
Result := FCreatures.Items[i];
end;
function TSimWorld.GetCreatureCount: integer;
begin
Result := FCreatures.Count;
end;
function TSimWorld.GetTimeSpeed: integer;
begin
Result := Timer.Interval;
end;
procedure TSimWorld.SetTimeSpeed(const Value: integer);
begin
Timer.Interval := Value;
end;
{ TBrick }
constructor TBrick.Create(const X, Y, W, H: longint; aWorld: TSimWorld; anImage: TMosaic = nil);
begin
inherited;
Image.Picture.LoadFromFile('Brick.bmp');
Image.Picture.Graphic.Transparent := true;
Image.Tile := true;
end;
{ TSimObject }
constructor TSimObject.Create(const X, Y, W, H: longint; aWorld: TSimWorld; anImage: TMosaic = nil);
begin
inherited Create;
Position.X := X;
Position.Y := Y;
Size.Width := W;
Size.Height := H;
World := aWorld;
if anImage = nil
then Image := TMosaic.Create(World.Ground)
else Image := anImage;
with Image do
begin
Left := X;
Top := Y;
Width := W;
Height := H;
end;
end;
destructor TSimObject.Destroy;
begin
Image.free;
end;
procedure TSimObject.SetBitmap(const index: integer; Bitmap: TBitmap);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
World.Images.GetBitmap(index, bm);
Bitmap.Assign(bm);
bm.free;
end;
procedure TSimObject.SetImage(const ImageID: integer);
begin
SetBitmap(ImageID, Image.Picture.Bitmap);
Image.Picture.Graphic.Transparent := true;
end;
procedure TSimObject.SetSurmountable(const Value: boolean);
begin
FSurmountable := Value;
end;
{ TQuarry }
procedure TQuarry.CheckSate;
begin
if CapacityPercent < 100
then SetImage(QuarryType + 1 + CapacityPercent div 20);
end;
constructor TQuarry.Create(const X, Y, W, H, aStartCap: Integer; aWorld: TSimWorld; anImage: TMosaic = nil);
begin
inherited Create(X, Y, W, H, aWorld);
World := aWorld;
SetImage(YELLOW_5);
Image.Tile := true;
StartCapacity := aStartCap;
FCapacity := StartCapacity;
FSurmountable := true;
end;
function TQuarry.GetCapacityPercent: TPercent;
begin
Result := 100 * Capacity div StartCapacity;
end;
procedure TQuarry.SetCapacity(const Value: longint);
begin
if Value < 0
then FCapacity := 0
else FCapacity := Value;
end;
{ TSegment }
constructor TSegment.Create(aACreature: TACreature; Previous: TSegment; anImage: TMosaic = nil;
const X: longint = 0; const Y: longint = 0; const W: longint = 0);
begin
inherited Create(X, Y, W, W, aACreature.World, anImage);
ACreature := aACreature;
if Previous = nil
then Image.PictureName := 'HeadRight.bmp'
else Image.PictureName := 'Segment.bmp';
Image.OnClick := OnClick;
Image.Tile := false;
Left := X;
Top := Y;
Width := W;
FPrevious := Previous;
if ACreature.World.Bump(X, Y, X + Width, Y + Width, Self)
then Top := Previous.Top;
end;
function TSegment.GetBottom: integer;
begin
Result := Top + Width;
end;
function TSegment.GetLeft: integer;
begin
Result := Position.X;