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