1program tclock;
2{$MODE OBJFPC}
3
4uses
5  ncurses, sysutils, initc;
6
7procedure setlocale(cat : integer; p : pchar); cdecl; external clib;
8
9
10const
11  LC_ALL = 6;
12
13const
14  ASPECT = 2.2;
15  _2PI = 2.0 * PI;
16
17function sign(_x: Integer): Integer;
18begin
19  if _x < 0 then
20    sign := -1
21  else
22    sign := 1
23end;
24
25function A2X(angle,radius: Double): Integer; inline;
26begin
27  A2X := round(ASPECT * radius * sin(angle))
28end;
29
30function A2Y(angle,radius: Double): Integer; inline;
31begin
32  A2Y := round(radius * cos(angle))
33end;
34
35type
36  PRchar = ^TRchar;
37  TRchar = record
38    ry,rx: Smallint;
39    rch: chtype;
40  end;
41
42procedure restore( rest: PRchar );
43var
44  i: Longint = 0;
45begin
46  while rest[i].rch <> 0 do
47  begin
48    with rest[i] do
49      mvaddch(ry, rx, rch);
50    Inc(i);
51  end;
52  freemem(rest)
53end;
54
55(* Draw a diagonal(arbitrary) line using Bresenham's alogrithm. *)
56procedure dline(from_y, from_x, end_y,  end_x: Smallint; ch: chtype; var rest: PRchar);
57var
58  dx, dy: Smallint;
59  ax, ay: Smallint;
60  sx, sy: Smallint;
61  x, y, d, i: Smallint;
62begin
63  dx := end_x - from_x;
64  dy := end_y - from_y;
65
66  ax := abs(dx * 2);
67  ay := abs(dy * 2);
68
69  sx := sign(dx);
70  sy := sign(dy);
71
72  x := from_x;
73  y := from_y;
74
75  i := 0;
76  if (ax > ay) then
77  begin
78    getmem(rest, sizeof(TRchar)*(abs(dx)+3));
79    d := ay - (ax DIV 2);
80
81    while true do
82    begin
83      move(y, x);
84      with rest[i] do
85      begin
86        rch := inch;
87        ry := y;
88        rx := x;
89        Inc(i)
90      end;
91      addch(ch);
92      if (x = end_x) then
93      begin
94        rest[i].rch := 0;
95        exit;
96      end;
97
98      if (d >= 0) then
99      begin
100        y += sy;
101        d -= ax;
102      end;
103      x += sx;
104      d += ay;
105    end
106  end
107  else
108  begin
109    getmem(rest, sizeof(TRchar)*(abs(dy)+3));
110    d := ax - (ay DIV 2);
111
112    while true do
113    begin
114      move(y, x);
115      with rest[i] do
116      begin
117        rch := inch;
118        ry := y;
119        rx := x;
120        Inc(i)
121      end;
122      addch(ch);
123      if (y = end_y) then
124      begin
125        rest[i].rch := 0;
126        exit;
127      end;
128
129      if (d >= 0) then
130      begin
131        x += sx;
132        d -= ay;
133      end;
134      y += sy;
135      d += ax;
136    end
137  end
138end;
139
140
141var
142  cx, cy: Integer;
143  cr, sradius, mradius, hradius: Double;
144
145
146procedure clockinit;
147const
148  title1 = 'Free pascal';
149  title2 = 'ncurses clock';
150  title3 = 'Press F10 or q to exit';
151var
152  i: Integer;
153  vstr, tstr: AnsiString;
154  angle: Double;
155begin
156  cx := (COLS - 1) DIV 2;
157  cy := LINES DIV 2;
158  if (cx / ASPECT < cy) then
159  cr := cx / ASPECT
160    else
161  cr := cy;
162
163  sradius := (8 * cr) / 9;
164  mradius := (3 * cr) / 4;
165  hradius := cr / 2;
166
167
168  for i := 1 to 24 do
169  begin
170    angle := i * _2PI / 24.0;
171
172
173    if (i MOD 2) = 0 then
174    begin
175      Str (i DIV 2, tstr);
176      attron(A_BOLD OR COLOR_PAIR(5));
177      mvaddstr(cy - A2Y(angle, sradius), cx + A2X(angle, sradius), @tstr[1]);
178      attroff(A_BOLD OR COLOR_PAIR(5));
179    end
180    else
181    begin
182      attron(COLOR_PAIR(1));
183      mvaddch(cy - A2Y(angle, sradius), cx + A2X(angle, sradius), chtype('.'));
184      attroff(COLOR_PAIR(1));
185    end
186  end;
187
188  vstr := curses_version;
189
190  attron(A_DIM OR COLOR_PAIR(2));
191  mvhline(cy , cx - round(sradius * ASPECT) + 1, ACS_HLINE,  round(sradius * ASPECT) * 2 - 1);
192  mvvline(cy - round(sradius) + 1, cx , ACS_VLINE,  round(sradius) * 2 - 1);
193  attroff(A_DIM OR COLOR_PAIR(1));
194  attron(COLOR_PAIR(3));
195  mvaddstr(cy - 5, cx - Length(title1) DIV 2, title1);
196  mvaddstr(cy - 4, cx - Length(title2) DIV 2, title2);
197  mvaddstr(cy - 3, cx - Length(vstr) DIV 2, PChar(vstr));
198  attroff(COLOR_PAIR(3));
199  attron(A_UNDERLINE);
200  mvaddstr(cy + 2, cx - Length(title3) DIV 2, title3);
201  attroff(A_UNDERLINE);
202end;
203
204
205var
206  angle: Double;
207  ch: chtype = 0;
208  Hour, Min, Sec, Msec: Word;
209  Hrest, Mrest, Srest: PRchar;
210  timestr: AnsiString;
211  my_bg: Smallint = COLOR_BLACK;
212begin
213  setlocale(LC_ALL, '');
214
215  try
216    initscr();
217    noecho();
218    cbreak();
219
220    halfdelay(10);
221    keypad(stdscr, TRUE);
222    curs_set(0);
223
224    if (has_colors()) then
225    begin
226      start_color();
227      if (use_default_colors() = OK) then
228        my_bg := -1;
229
230      init_pair(1, COLOR_YELLOW, my_bg);
231      init_pair(2, COLOR_RED, my_bg);
232      init_pair(3, COLOR_GREEN, my_bg);
233      init_pair(4, COLOR_CYAN, my_bg);
234      init_pair(5, COLOR_YELLOW, COLOR_BLACK) ;
235    end;
236
237    clockinit;
238    repeat
239      if (ch = KEY_RESIZE) then
240      begin
241        flash();
242        erase();
243        wrefresh(curscr);
244        clockinit;
245      end;
246
247      decodeTime(Time, Hour, Min, Sec, Msec);
248      Hour := Hour MOD 12;
249
250      timestr := DateTimeToStr(Now);
251      mvaddstr(cy + round(sradius) - 4, cx - Length(timestr) DIV 2, PChar(timestr));
252
253      angle := Hour * _2PI / 12;
254      dline(cy, cx, cy - A2Y(angle, hradius), cx + A2X(angle, hradius), chtype('*'),Hrest);
255
256      angle := Min * _2PI / 60;
257      dline(cy, cx, cy - A2Y(angle, mradius), cx + A2X(angle, mradius), chtype('*'),Mrest);
258
259      angle := Sec * _2PI / 60;
260      dline(cy, cx, cy - A2Y(angle, sradius), cx + A2X(angle, sradius), chtype('.'),Srest);
261
262      ch := getch();
263
264      restore(Srest);
265      restore(Mrest);
266      restore(Hrest);
267
268    until (ch = chtype('q')) OR (ch = KEY_F(10));
269  finally
270    curs_set(1);
271    endwin();
272  end;
273end.
274