1. unit Unit1;
2. {$codepage utf8}
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9.   ExtCtrls;
10.  
11. type
12.  
13.   { TForm1 }
14.  
15.   TForm1 = class(TForm)
16.     Button1: TButton;
17.     Button2: TButton;
18.     Button3: TButton;
19.     Button4: TButton;
20.     Button5: TButton;
21.     Button6: TButton;
22.     d1: TLabel;
23.     Edit1: TEdit;
24.     Edit2: TEdit;
25.     Edit3: TEdit;
26.     Edit4: TEdit;
27.     b: TLabel;
28.     Edit5: TEdit;
29.     Edit6: TEdit;
30.     Label1: TLabel;
31.     Grecka: TLabel;
32.     Label3: TLabel;
33.     d: TLabel;
34.     GrNaRzymska: TRadioButton;
35.     Zakres1: TRadioButton;
36.     Zakres2: TRadioButton;
37.     RadioGroup1: TRadioGroup;
38.     RzNaArabska: TRadioButton;
39.     GrNaArabska: TRadioButton;
40.     RzNaGrecka: TRadioButton;
41.     NaRzymska: TRadioButton;
42.     NaGrecka: TRadioButton;
43.     procedure Edit5Change(Sender: TObject);
44.     procedure GreckaClick(Sender: TObject);
45.     procedure RadioGroup1Click(Sender: TObject);
46.     procedure RzNaArabskaChange(Sender: TObject);
47.     procedure Button1Click(Sender: TObject);
48.     procedure Button2Click(Sender: TObject);
49.     procedure Button3Click(Sender: TObject);
50.     procedure Button4Click(Sender: TObject);
51.     procedure Button5Click(Sender: TObject);
52.     procedure Button6Click(Sender: TObject);
53.     procedure Edit1Change(Sender: TObject);
54.     procedure Edit2Change(Sender: TObject);
55.     procedure Label1Click(Sender: TObject);
56.     procedure RzNaArabskaClick(Sender: TObject);
57.     procedure NaGreckaChange(Sender: TObject);
58.     procedure NaRzymskaChange(Sender: TObject);
59.     procedure NaRzymskaClick(Sender: TObject);
60.     procedure ZakresNChange(Sender: TObject);
61.   private
62.     { private declarations }
63.   public
64.     { public declarations }
65.   end;
66.  
67. var
68.   Form1: TForm1;
69.   a: integer;
70.   mnoznik: integer;
71.   aa: integer;
72.   c: integer;
73.   i: integer;
74.   j: integer;
75.   T: string;
76.   lrzym: string;
77.   lgrec: string;
78.   wynik:integer = 0;
79.   add, min, sum: integer;
80.   pom:boolean;
81.   rzym:string;
82.   GreckieJedn : array[1..9] of string =  ('α', 'β', 'γ', 'δ', 'ε',
83.   'ϝ', 'ζ', 'η', 'θ');
84.   GreckieDzie : array[1..9] of string =  ('ι', 'κ', 'λ', 'μ', 'ν',
85.   'ξ', 'ο', 'π', 'ϟ');
86.   GreckieSet : array[1..9] of string =  ('ρ', 'σ', 'τ', 'υ', 'φ',
87.   'χ', 'ψ', 'ω', 'ϡ');
88.  
89.  
90.  
91.  
92.  
93. implementation
94.  
95. function GreckaWartosc(Gr : UnicodeString) : integer;
96. begin
97.   aa := 0;
98.  
99.   for j:=1 to 9 do
100.     begin
101.          if(GreckieJedn[j] = Gr) then aa := j;
102.     end;
103.  
104.   for j:=1 to 9 do
105.     begin
106.          if(GreckieDzie[j] = Gr) then aa := j * 10;
107.     end;
108.  
109.   for j:=1 to 9 do
110.     begin
111.          if(GreckieSet[j] = Gr) then aa := j * 100;
112.     end;
113.  
114.   Result := aa;
115. end;
116.  
117.  
118. function Wstaw(a : integer; one, five, ten : string) : string;
119. begin
120.   T:='';
121.   if a < 4 then
122.     for i:=1 to a do T:=T+one;
123.   if a = 4 then
124.     T:=one + five;
125.   if a = 5 then
126.     T := five;
127.   if (a > 5) and (a < 9) then
128.   begin
129.     T:=five;
130.     for i:=1 to a - 5 do  T:=T+one;
131.   end;
132.   if a = 9 then T:=one+ten;
133.  
134. Result := T;
135. end;
136.  
137. function StworzArabskaZGreckiej(Gre : UnicodeString) : integer;
138. begin
139.      sum := 0;
140.      mnoznik := 1;
141.      for i:=1 to Length(Gre) do
142.        begin
143.          add := 0;
144.          if(Gre[i] = '͵') then mnoznik := 1000;
145.          if(Gre[i] <> '͵') then add := GreckaWartosc(Gre[i]);
146.  
147.          if(add > 0) then
148.          begin
149.               sum := sum + (add * mnoznik);
150.               mnoznik := 1;
151.          end;
152.  
153.        end;
154.      Result := sum;
155. end;
156.  
157. function StworzArabskaZRzymskiej(Rzym : string) : integer;
158. begin
159.     sum := 0;
160.     pom := false;
161.     mnoznik := 0;
162.     for i:= 1 to Length(Rzym) do
163.       begin
164.         add := 0;
165.         min := 0;
166.  
167.         if pom = false then
168.           begin
169.             case Rzym[i] of
170.                 'M': add := 1000;
171.                 'D': add := 500;
172.                 'C': add := 100;
173.                 'L': add := 50;
174.                 'X': add := 10;
175.                 'V': add := 5;
176.                 'I': add := 1;
177.                 '|': mnoznik := mnoznik + 1;
178.             end;
179.  
180.             case Rzym[i + 1] of
181.                 'M': min := 1000;
182.                 'D': min := 500;
183.                 'C': min := 100;
184.                 'L': min := 50;
185.                 'X': min := 10;
186.                 'V': min := 5;
187.                 'I': min := 1;
188.             end;
189.  
190.             if (add < min) and (add > 0) then
191.               begin
192.                 add := min - add;
193.                 pom := true;
194.               end;
195.             sum := sum + add;
196.             if(mnoznik = 2) then
197.               begin
198.                  sum := sum * 1000;
199.                  mnoznik := 3;
200.               end;
201.           end
202.         else
203.           pom := false;
204.       end;
205.     Result := sum;
206. end;
207.  
208. function StworzGrecka(a : integer) : string;
209. begin
210.      lgrec := '';
211.  
212.      if(a > 999999) then
213.        begin
214.          ShowMessage('Liczby greckie obejmują zakres od 1 do 999999. Wprowadź inną liczbę');
215.          Result := 'bląd';
216.          exit;
217.        end;
218.  
219.      if(a > 999) then
220.      begin
221.          aa := a div 1000;
222.  
223.          if(aa div 100) > 0 then
224.          begin
225.            lgrec := lgrec + '͵' + GreckieSet[aa div 100];
226.            aa := aa mod 100;
227.          end;
228.  
229.  
230.          if(aa div 10) > 0 then
231.          begin
232.            lgrec := lgrec + '͵' + GreckieDzie[aa div 10];
233.            aa := aa mod 10;
234.          end;
235.  
236.          if(aa > 0) then lgrec := lgrec + '͵' + GreckieJedn[aa];
237.  
238.          a := a mod 1000;
239.      end;
240.  
241.      if(a div 100) > 0 then
242.      begin
243.           lgrec := lgrec + GreckieSet[a div 100];
244.           a := a mod 100;
245.      end;
246.  
247.  
248.      if(a div 10) > 0 then
249.      begin
250.           lgrec := lgrec + GreckieDzie[a div 10];
251.           a := a mod 10;
252.      end;
253.  
254.      if(a > 0) then lgrec := lgrec + GreckieJedn[a];
255.  
256.      lgrec := lgrec + 'ʹ';
257.  
258.      Result := lgrec;
259. end;
260.  
261. function StworzRzymska(a : integer; Zakres1, Zakres2 : boolean) : string;
262. begin
263.     lrzym := '';
264.  
265.     if Zakres1 then
266.     begin
267.       if a >= 4000 then
268.       begin
269.         ShowMessage('Ta liczba wychodzi poza zaznaczony zakres');
270.         Result := 'bląd';
271.         exit;
272.       end;
273.     end;
274.     if Zakres2 then
275.     begin
276.       if (a < 4000) or (a > 300000) then
277.       begin
278.         ShowMessage('Ta liczba wychodzi poza zaznaczony zakres');
279.         Result := 'bląd';
280.         exit;
281.       end;
282.     end;
283.  
284.    if (a >= 4000) then
285.        begin
286.          lrzym := '|';
287.  
288.          aa := a div 1000;
289.  
290.          if (aa div 1000) > 0 then
291.          begin
292.            for i := 1 to aa div 1000 do
293.              lrzym := lrzym +'M';
294.            aa := aa mod 1000;
295.          end;
296.  
297.          if (aa div 100) > 0 then
298.          begin
299.            lrzym := lrzym + Wstaw(aa div 100,'C','D','M');
300.            aa := aa mod 100;
301.          end;
302.  
303.          if (aa div 10) > 0 then
304.          begin
305.            lrzym := lrzym + Wstaw(aa div 10,'X','L','C');
306.            aa := aa mod 10;
307.          end;
308.  
309.          if aa > 0 then
310.          lrzym := lrzym + Wstaw(aa,'I','V','X');
311.  
312.          lrzym := lrzym + '|';
313.  
314.          a := a mod 1000;
315.        end;
316.        if (a div 1000) > 0 then
317.        begin
318.          for i := 1 to a div 1000 do
319.            lrzym := lrzym +'M';
320.          a := a mod 1000;
321.        end;
322.  
323.        if (a div 100) > 0 then
324.          begin
325.            lrzym := lrzym + Wstaw(a div 100,'C','D','M');
326.            a := a mod 100;
327.          end;
328.  
329.        if (a div 10) > 0 then
330.          begin
331.            lrzym := lrzym + Wstaw(a div 10,'X','L','C');
332.            a := a mod 10;
333.          end;
334.  
335.        if a > 0 then
336.          lrzym := lrzym + Wstaw(a,'I','V','X');
337.  
338.        Result := lrzym;
339. end;
340.  
341. {$R *.lfm}
342.  
343. { TForm1 }
344.  
345. procedure TForm1.Label1Click(Sender: TObject);
346. begin
347.  
348. end;
349.  
350. procedure TForm1.RzNaArabskaClick(Sender: TObject);
351. begin
352.  
353. end;
354.  
355. procedure TForm1.NaGreckaChange(Sender: TObject);
356. begin
357.  
358. end;
359.  
360. procedure TForm1.NaRzymskaChange(Sender: TObject);
361. begin
362.  
363. end;
364.  
365. procedure TForm1.NaRzymskaClick(Sender: TObject);
366. begin
367.  
368. end;
369.  
370. procedure TForm1.ZakresNChange(Sender: TObject);
371. begin
372.  
373. end;
374.  
375.  
376. procedure TForm1.Edit1Change(Sender: TObject);
377. begin
378.  
379. end;
380.  
381. procedure TForm1.Edit2Change(Sender: TObject);
382. begin
383.  
384. end;
385.  
386. procedure TForm1.Button1Click(Sender: TObject);
387. begin
388.      if(Length(Edit1.text) = 0) then exit;
389.      a:=strtoint(Edit1.text);
390.  
391.      if (NaRzymska.Checked) then
392.        Edit2.text:=StworzRzymska(a, Zakres1.Checked, Zakres2.Checked);
393.  
394.      if (NaGrecka.Checked) then
395.        Edit2.text:=StworzGrecka(a);
396.  
397. end;
398.  
399. procedure TForm1.RzNaArabskaChange(Sender: TObject);
400. begin
401.  
402. end;
403.  
404. procedure TForm1.GreckaClick(Sender: TObject);
405. begin
406.  
407. end;
408.  
409. procedure TForm1.RadioGroup1Click(Sender: TObject);
410. begin
411.  
412. end;
413.  
414. procedure TForm1.Edit5Change(Sender: TObject);
415. begin
416.  
417. end;
418.  
419. procedure TForm1.Button2Click(Sender: TObject);
420. begin
421.   Edit1.text:=' ';
422.   Edit2.text:=' ';
423. end;
424.  
425. procedure TForm1.Button3Click(Sender: TObject);
426. begin
427.   if RzNaArabska.Checked then
428.      Edit4.text := inttostr(StworzArabskaZRzymskiej(Edit3.text));
429.   if RzNaGrecka.Checked then
430.      Edit4.text := StworzGrecka(StworzArabskaZRzymskiej(Edit3.text));
431.  
432. end;
433.  
434. procedure TForm1.Button4Click(Sender: TObject);
435. begin
436.   Edit3.text:=' ';
437.   Edit4.text:=' ';
438. end;
439.  
440. procedure TForm1.Button5Click(Sender: TObject);
441. begin
442.      if GrNaArabska.Checked then
443.      Edit6.text := inttostr(StworzArabskaZGreckiej(Edit5.text));
444.      if GrNaRzymska.Checked then
445.      Edit6.text := StworzRzymska(StworzArabskaZGreckiej(Edit5.text), Zakres1.Checked, Zakres2.Checked);
446. end;
447.  
448. procedure TForm1.Button6Click(Sender: TObject);
449. begin
450.   Edit5.text:=' ';
451.   Edit6.text:=' ';
452. end;
453.  
454.  
455.  
456. end.
457.