initial cammit
[qbasicapps.git] / automation / school clock / kell / kk.bas
1 DECLARE SUB num (a%)\r
2 DECLARE SUB mntime ()\r
3 DECLARE SUB showit ()\r
4 DECLARE SUB ekrf (a%)\r
5 DECLARE SUB ekr ()\r
6 DECLARE SUB rese ()\r
7 DECLARE SUB start ()\r
8 DECLARE SUB boot ()\r
9 DECLARE SUB getnad (g%, n%, d%, k%)\r
10 DECLARE SUB initp (b$)\r
11 DECLARE SUB getmd (a$, m%, d%)\r
12 DECLARE SUB son (a$)\r
13 DEFINT A-Z\r
14 \r
15 DECLARE SUB inita ()\r
16 DECLARE SUB chm ()\r
17 DECLARE SUB chd ()\r
18 DECLARE SUB kell (a%)\r
19 DECLARE SUB sync2 ()\r
20 DECLARE SUB sync ()\r
21 DECLARE SUB mnmain ()\r
22 DECLARE SUB main ()\r
23 DECLARE SUB getkey (kla%)\r
24 DECLARE SUB klnait (k%)\r
25 DECLARE SUB heli (a%)\r
26 DECLARE SUB keys ()\r
27 DECLARE SUB disp ()\r
28 DIM SHARED bit(0 TO 7)\r
29 DIM SHARED kl\r
30 DIM SHARED hist(1 TO 3)\r
31 DIM SHARED ap$(1 TO 500)\r
32 DIM SHARED apl\r
33 DIM SHARED pp$(1 TO 500)\r
34 DIM SHARED ppl\r
35 DIM SHARED prt, prt2\r
36 DIM SHARED timo$\r
37 DIM SHARED dato$\r
38 DIM SHARED sona$(1 TO 50)\r
39 DIM SHARED mitus\r
40 DIM SHARED lp$\r
41 DIM SHARED ndlp\r
42 DIM SHARED pn$(1 TO 7)\r
43 DIM SHARED bitt(1 TO 16)\r
44 DIM SHARED modee, vilgu\r
45 DIM SHARED tul(1 TO 2)\r
46 \r
47 start\r
48 heli 4\r
49 \r
50 \r
51 disp\r
52 mnmain\r
53 \r
54 SUB chd\r
55 b$ = "tuhi"\r
56 IF apl = 0 THEN inita\r
57 \r
58 a$ = DATE$\r
59 n1 = VAL(RIGHT$(a$, 4))\r
60 n2 = VAL(LEFT$(a$, 2))\r
61 a$ = LEFT$(a$, 5)\r
62 n3 = VAL(RIGHT$(a$, 2))\r
63 getnad n1, n2, n3, ndlp\r
64 LOCATE 10, 1\r
65 PRINT "n\84dalap\84ev:", pn$(ndlp)\r
66 FOR a = 1 TO apl\r
67 son ap$(a)\r
68 SELECT CASE sona$(1)\r
69 CASE "v"\r
70 getmd sona$(2), m1, d1\r
71 getmd sona$(3), m2, d2\r
72 getmd DATE$, m3, d3\r
73 IF m3 < m1 THEN GOTO 9\r
74 IF m3 > m2 THEN GOTO 9\r
75 IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9\r
76 IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9\r
77 b$ = sona$(4)\r
78 CASE "n"\r
79 getmd sona$(2), m1, d1\r
80 getmd sona$(3), m2, d2\r
81 getmd DATE$, m3, d3\r
82 IF m3 < m1 THEN GOTO 9\r
83 IF m3 > m2 THEN GOTO 9\r
84 IF m3 = m1 THEN IF d3 < d1 THEN GOTO 9\r
85 IF m3 = m2 THEN IF d3 > d2 THEN GOTO 9\r
86 IF ndlp <> VAL(sona$(4)) THEN GOTO 9\r
87 b$ = sona$(5)\r
88 CASE "e"\r
89 getmd sona$(2), m1, d1\r
90 getmd DATE$, m2, d2\r
91 IF (m1 = m2) AND (d1 = d2) THEN b$ = sona$(3)\r
92 END SELECT\r
93 9\r
94 NEXT a\r
95 \r
96 IF b$ <> lp$ THEN initp b$\r
97 lp$ = b$\r
98 LOCATE 9, 1\r
99 PRINT "p\84evaplaan:", lp$\r
100 END SUB\r
101 \r
102 SUB chm\r
103 showit\r
104 a$ = DATE$\r
105 IF a$ <> dato$ THEN chd\r
106 dato$ = a$\r
107 b = 0\r
108 FOR a = 1 TO ppl\r
109 son pp$(a)\r
110 SELECT CASE sona$(1)\r
111 CASE "#"\r
112 getmd sona$(2), h1, m1\r
113 getmd TIME$, h2, m2\r
114 ' PRINT h1, m1, h2, m2\r
115 IF (h2 = h1) AND (m2 = m1) THEN\r
116 IF sona$(3) = "sis" THEN b = 1\r
117 IF sona$(3) = "val" THEN b = 2\r
118 END IF\r
119 END SELECT\r
120 NEXT a\r
121 \r
122 IF b > 0 THEN kell b\r
123 \r
124 END SUB\r
125 \r
126 SUB disp\r
127 CLS\r
128 PRINT "Kooli Kell  v 1.2  2002.10.10"\r
129 PRINT "Programmi autor Svjatoslav Agejenko"\r
130 \r
131 END SUB\r
132 \r
133 SUB ekr\r
134 FOR e = 1 TO 10\r
135 c = 1\r
136 c = c + 16 * bitt(1)\r
137 c = c + 32 * bitt(2)\r
138 c = c + 64 * bitt(3)\r
139 c = c + 128 * bitt(4)\r
140 OUT prt2, c\r
141 \r
142 c = 2\r
143 c = c + 16 * bitt(5)\r
144 c = c + 32 * bitt(6)\r
145 c = c + 64 * bitt(7)\r
146 c = c + 128 * bitt(8)\r
147 OUT prt2, c\r
148 \r
149 c = 4\r
150 c = c + 16 * bitt(9)\r
151 c = c + 32 * bitt(10)\r
152 c = c + 64 * bitt(11)\r
153 c = c + 128 * bitt(12)\r
154 OUT prt2, c\r
155 \r
156 c = 8\r
157 c = c + 16 * bitt(13)\r
158 c = c + 32 * bitt(14)\r
159 c = c + 64 * bitt(15)\r
160 c = c + 128 * bitt(16)\r
161 OUT prt2, c\r
162 \r
163 \r
164 NEXT e\r
165 END SUB\r
166 \r
167 SUB ekrf (a)\r
168 SELECT CASE (a)\r
169 CASE 0\r
170 bitt(1) = 0\r
171 bitt(2) = 0\r
172 bitt(3) = 0\r
173 bitt(7) = 0\r
174 bitt(5) = 0\r
175 bitt(6) = 0\r
176 bitt(8) = 1\r
177 CASE 1\r
178 bitt(2) = 0\r
179 bitt(7) = 0\r
180 CASE 2\r
181 bitt(1) = 0\r
182 bitt(3) = 0\r
183 bitt(5) = 0\r
184 bitt(7) = 0\r
185 bitt(8) = 0\r
186 CASE 3\r
187 bitt(1) = 0\r
188 bitt(2) = 0\r
189 bitt(5) = 0\r
190 bitt(8) = 0\r
191 bitt(7) = 0\r
192 CASE 4\r
193 bitt(2) = 0\r
194 bitt(6) = 0\r
195 bitt(7) = 0\r
196 bitt(8) = 0\r
197 CASE 5\r
198 bitt(1) = 0\r
199 bitt(2) = 0\r
200 bitt(5) = 0\r
201 bitt(6) = 0\r
202 bitt(8) = 0\r
203 CASE 6\r
204 bitt(1) = 0\r
205 bitt(2) = 0\r
206 bitt(3) = 0\r
207 bitt(5) = 0\r
208 bitt(6) = 0\r
209 bitt(8) = 0\r
210 CASE 7\r
211 bitt(2) = 0\r
212 bitt(7) = 0\r
213 bitt(5) = 0\r
214 CASE 8\r
215 bitt(1) = 0\r
216 bitt(2) = 0\r
217 bitt(3) = 0\r
218 bitt(7) = 0\r
219 bitt(5) = 0\r
220 bitt(6) = 0\r
221 bitt(8) = 0\r
222 CASE 9\r
223 bitt(1) = 0\r
224 bitt(2) = 0\r
225 bitt(7) = 0\r
226 bitt(5) = 0\r
227 bitt(6) = 0\r
228 bitt(8) = 0\r
229 CASE 10\r
230 bitt(15) = 0\r
231 bitt(16) = 0\r
232 bitt(12) = 0\r
233 bitt(10) = 0\r
234 bitt(9) = 0\r
235 bitt(4) = 0\r
236 CASE 11\r
237 bitt(15) = 0\r
238 bitt(4) = 0\r
239 CASE 12\r
240 bitt(15) = 0\r
241 bitt(16) = 0\r
242 bitt(9) = 0\r
243 bitt(10) = 0\r
244 bitt(11) = 0\r
245 CASE 13\r
246 bitt(15) = 0\r
247 bitt(4) = 0\r
248 bitt(16) = 0\r
249 bitt(11) = 0\r
250 bitt(9) = 0\r
251 CASE 14\r
252 bitt(15) = 0\r
253 bitt(4) = 0\r
254 bitt(12) = 0\r
255 bitt(11) = 0\r
256 CASE 15\r
257 bitt(9) = 0\r
258 bitt(4) = 0\r
259 bitt(11) = 0\r
260 bitt(12) = 0\r
261 bitt(16) = 0\r
262 CASE 16\r
263 bitt(9) = 0\r
264 bitt(4) = 0\r
265 bitt(11) = 0\r
266 bitt(12) = 0\r
267 bitt(16) = 0\r
268 bitt(10) = 0\r
269 CASE 17\r
270 bitt(4) = 0\r
271 bitt(15) = 0\r
272 bitt(16) = 0\r
273 CASE 18\r
274 bitt(4) = 0\r
275 bitt(15) = 0\r
276 bitt(16) = 0\r
277 bitt(12) = 0\r
278 bitt(11) = 0\r
279 bitt(10) = 0\r
280 bitt(9) = 0\r
281 CASE 19\r
282 bitt(4) = 0\r
283 bitt(15) = 0\r
284 bitt(16) = 0\r
285 bitt(12) = 0\r
286 bitt(11) = 0\r
287 bitt(9) = 0\r
288 END SELECT\r
289 \r
290 END SUB\r
291 \r
292 SUB getkey (kla)\r
293 \r
294 1\r
295 IF vilgu = 1 THEN\r
296 tmr = tmr + 1\r
297 IF tmr > 5 THEN bitt(13) = tul(1): bitt(14) = tul(2) ELSE bitt(13) = 1: bitt(14) = 1\r
298 IF tmr > 10 THEN\r
299 tmr = 0\r
300 END IF\r
301 ELSE\r
302 bitt(13) = tul(1)\r
303 bitt(14) = tul(2)\r
304 END IF\r
305 \r
306 b$ = LEFT$(TIME$, 5)\r
307 IF b$ <> timo$ THEN chm\r
308 timo$ = b$\r
309 hist(1) = hist(1) + 1\r
310 IF hist(1) > 20000 THEN hist(1) = 15000\r
311 hist(2) = hist(2) + 1\r
312 IF hist(2) > 20000 THEN hist(2) = 15000\r
313 hist(3) = hist(3) + 1\r
314 IF hist(3) > 20000 THEN hist(3) = 15000\r
315 \r
316 keys\r
317 IF kl > 0 THEN\r
318   IF hist(kl) > 1 AND hist(kl) < 9 THEN\r
319     klnait kl + 3\r
320     kla = kl + 3\r
321     GOTO 4\r
322   ELSE\r
323     hist(kl) = 0\r
324   END IF\r
325 END IF\r
326 IF hist(1) = 10 THEN klnait 1: kla = 1: GOTO 4\r
327 IF hist(2) = 10 THEN klnait 2: kla = 2: GOTO 4\r
328 IF hist(3) = 10 THEN klnait 3: kla = 3: GOTO 4\r
329 \r
330 IF hist(1) > 11 AND hist(2) > 11 AND hist(3) > 11 THEN klnait 0\r
331 LOCATE 7, 1\r
332 PRINT TIME$\r
333 LOCATE 8, 1\r
334 PRINT DATE$\r
335 GOTO 1\r
336 4\r
337 \r
338 \r
339 hist(1) = 10000\r
340 hist(2) = 10000\r
341 hist(3) = 10000\r
342 \r
343 FOR b = 1 TO 100\r
344 SOUND 0, .1\r
345 NEXT b\r
346 IF kla > 3 THEN SOUND 4000, .1 ELSE SOUND 3000, .1\r
347 \r
348 \r
349 \r
350 END SUB\r
351 \r
352 SUB getmd (a$, m, d)\r
353 b$ = LEFT$(a$, 5)\r
354 m = VAL(LEFT$(b$, 2))\r
355 d = VAL(RIGHT$(b$, 2))\r
356 \r
357 END SUB\r
358 \r
359 SUB getnad (g, n, d, k)\r
360 LOCATE 11, 1\r
361 PRINT g, n, d\r
362 p = g\r
363 m = n - 2\r
364 IF n > 2 GOTO 120\r
365 p = p - 1: m = m + 12\r
366 120\r
367 c = INT(p / 100)\r
368 y = p - c * 100\r
369 w = d + INT((13 * m - 1) / 5) + y + INT(y / 4) + INT(c / 4) - 2 * c\r
370 k = w - 7 * INT(w / 7)\r
371 IF k = 0 THEN k = 7\r
372 END SUB\r
373 \r
374 SUB heli (a)\r
375 'GOTO 10\r
376 SELECT CASE a\r
377 CASE 1\r
378 FOR c = 1 TO 5\r
379 SOUND 3000, 1\r
380 SOUND 0, 1\r
381 NEXT c\r
382 \r
383 CASE 2\r
384 FOR c = 1 TO 5\r
385 SOUND 2500, 1\r
386 SOUND 0, 2\r
387 NEXT c\r
388 SOUND 2500, 10\r
389 \r
390 CASE 3\r
391 FOR a = 1 TO 10\r
392 SOUND 500, .5\r
393 SOUND 1500, .5\r
394 SOUND 2000, .5\r
395 SOUND 1520, .5\r
396 NEXT a\r
397 \r
398 \r
399 CASE 4\r
400 FOR a = 800 TO 1000 STEP 10\r
401 SOUND a, .1\r
402 SOUND a * 3, .1\r
403 SOUND 0, 1\r
404 NEXT a\r
405 10\r
406 \r
407 END SELECT\r
408 \r
409 \r
410 END SUB\r
411 \r
412 SUB inita\r
413 apl = 0\r
414 OPEN "aasta.ap" FOR INPUT AS #1\r
415 5\r
416 IF EOF(1) <> 0 THEN GOTO 3\r
417 LINE INPUT #1, a$\r
418 apl = apl + 1\r
419 ap$(apl) = a$\r
420 GOTO 5\r
421 3\r
422 CLOSE #1\r
423 END SUB\r
424 \r
425 SUB initp (b$)\r
426 ppl = 0\r
427 OPEN b$ + ".pp" FOR INPUT AS #1\r
428 6\r
429 IF EOF(1) <> 0 THEN GOTO 7\r
430 LINE INPUT #1, a$\r
431 ppl = ppl + 1\r
432 pp$(ppl) = a$\r
433 GOTO 6\r
434 7\r
435 CLOSE #1\r
436 END SUB\r
437 \r
438 SUB kell (a)\r
439 heli 3\r
440 \r
441 SELECT CASE a\r
442 CASE 1\r
443 OUT prt, 255\r
444 FOR b = 1 TO 80\r
445 SOUND 0, 1\r
446 NEXT b\r
447 OUT prt, 0\r
448 FOR b = 1 TO 15\r
449 SOUND 0, 1\r
450 NEXT b\r
451 OUT prt, 255\r
452 FOR b = 1 TO 15\r
453 SOUND 0, 1\r
454 NEXT b\r
455 OUT prt, 0\r
456 \r
457 CASE 2\r
458 OUT prt, 255\r
459 FOR b = 1 TO 80\r
460 SOUND 0, 1\r
461 NEXT b\r
462 OUT prt, 0\r
463 \r
464 END SELECT\r
465 END SUB\r
466 \r
467 SUB keys\r
468 kl = 0\r
469 OUT prt, 0\r
470 8\r
471 a = INP(prt)\r
472 b = INP(prt)\r
473 IF a <> b THEN GOTO 8\r
474 \r
475 b = 128\r
476 FOR c = 0 TO 7\r
477 d = INT(a / b)\r
478 bit(c) = d\r
479 a = a - (b * d)\r
480 b = b / 2\r
481 NEXT c\r
482 \r
483 IF bit(4) = 1 AND bit(6) = 1 THEN bit(4) = 0: bit(6) = 0: kl = 3\r
484 IF bit(6) = 1 THEN kl = 2\r
485 IF bit(4) = 1 THEN kl = 1\r
486 \r
487 a$ = INKEY$\r
488 IF a$ = CHR$(0) + "K" THEN kl = 1\r
489 IF a$ = CHR$(0) + "M" THEN kl = 2\r
490 IF a$ = CHR$(0) + "P" THEN kl = 3\r
491 ekr\r
492 END SUB\r
493 \r
494 SUB klnait (k)\r
495 \r
496 IF k = 3 THEN c = 3 ELSE c = 1\r
497 IF k = 6 THEN c = 14\r
498 LOCATE 5, 6\r
499 COLOR 7, c\r
500 PRINT "<kesk>"\r
501 COLOR 7, 0\r
502 \r
503 IF k = 1 THEN c = 3 ELSE c = 1\r
504 IF k = 4 THEN c = 14\r
505 LOCATE 4, 1\r
506 COLOR 7, c\r
507 PRINT "<vasak>"\r
508 COLOR 7, 0\r
509 \r
510 IF k = 2 THEN c = 3 ELSE c = 1\r
511 IF k = 5 THEN c = 14\r
512 LOCATE 4, 10\r
513 COLOR 7, c\r
514 PRINT "<parem>"\r
515 COLOR 7, 0\r
516 \r
517 END SUB\r
518 \r
519 SUB mnmain\r
520 2\r
521 getkey a\r
522 IF a = 6 THEN sync\r
523 IF a = 3 THEN sync2\r
524 \r
525 IF a = 1 THEN kell 1\r
526 IF a = 4 THEN kell 2\r
527 \r
528 IF a = 2 THEN mntime\r
529 IF a = 5 THEN rese\r
530 GOTO 2\r
531 \r
532 END SUB\r
533 \r
534 SUB mntime\r
535 vilgu = 1\r
536 11\r
537 showit\r
538 getkey a\r
539 \r
540 IF modee = 1 THEN\r
541   b = VAL(LEFT$(TIME$, 2))\r
542   c = 0\r
543   IF a = 1 THEN c = 1: b = b - 1\r
544   IF a = 2 THEN c = 1: b = b + 1\r
545   IF b < 0 THEN b = 0\r
546   IF b > 23 THEN b = 23\r
547   d$ = STR$(b)\r
548   IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)\r
549   IF LEN(d$) < 2 THEN d$ = "0" + d$\r
550   e$ = d$ + RIGHT$(TIME$, 6)\r
551   IF c = 1 THEN TIME$ = e$\r
552 ELSE\r
553   b = VAL(RIGHT$(LEFT$(TIME$, 5), 2))\r
554   c = 0\r
555   IF a = 1 THEN c = 1: b = b - 1\r
556   IF a = 2 THEN c = 1: b = b + 1\r
557   IF b < 0 THEN b = 0\r
558   IF b > 59 THEN b = 59\r
559   d$ = STR$(b)\r
560   IF LEFT$(d$, 1) = " " THEN d$ = RIGHT$(d$, LEN(d$) - 1)\r
561   IF LEN(d$) < 2 THEN d$ = "0" + d$\r
562   e$ = LEFT$(TIME$, 3) + d$ + RIGHT$(TIME$, 3)\r
563   IF c = 1 THEN TIME$ = e$\r
564 END IF\r
565 \r
566 IF a = 3 THEN\r
567 IF modee = 1 THEN modee = 2 ELSE modee = 1\r
568 END IF\r
569 \r
570 IF a = 6 THEN GOTO 12\r
571 GOTO 11\r
572 12\r
573 vilgu = 0\r
574 modee = 2\r
575 END SUB\r
576 \r
577 SUB num (a)\r
578 \r
579 FOR b = 1 TO 12\r
580 bitt(b) = 1\r
581 NEXT b\r
582 bitt(15) = 1\r
583 bitt(16) = 1\r
584 \r
585 b = INT(a / 10)\r
586 c = a - (10 * b)\r
587 ekrf b\r
588 ekrf c + 10\r
589 END SUB\r
590 \r
591 SUB rese\r
592 heli 4\r
593 timo$ = ""\r
594 dato$ = ""\r
595 apl = 0\r
596 END SUB\r
597 \r
598 SUB showit\r
599 a$ = LEFT$(TIME$, 5)\r
600 IF modee = 1 THEN\r
601 b = VAL(LEFT$(a$, 2))\r
602 tul(1) = 1\r
603 tul(2) = 0\r
604 ELSE\r
605 b = VAL(RIGHT$(a$, 2))\r
606 tul(1) = 0\r
607 tul(2) = 1\r
608 END IF\r
609 LOCATE 15, 1\r
610 PRINT b\r
611 num b\r
612 \r
613 \r
614 END SUB\r
615 \r
616 SUB son (a$)\r
617 \r
618 FOR b = 1 TO 50\r
619 sona$(b) = ""\r
620 NEXT b\r
621 mitus = 0\r
622 \r
623 b = 1\r
624 FOR c = 1 TO LEN(a$)\r
625 d$ = RIGHT$(LEFT$(a$, c), 1)\r
626 IF d$ = " " OR d$ = CHR$(9) THEN\r
627 b = 1\r
628 ELSE\r
629 IF b = 1 THEN b = 0: mitus = mitus + 1\r
630 sona$(mitus) = sona$(mitus) + d$\r
631 END IF\r
632 NEXT c\r
633 \r
634 \r
635 END SUB\r
636 \r
637 SUB start\r
638 pn$(1) = "esmasp\84ev"\r
639 pn$(2) = "teisip\84ev"\r
640 pn$(3) = "kolmap\84ev"\r
641 pn$(4) = "neljap\84ev"\r
642 pn$(5) = "reede"\r
643 pn$(6) = "laup\84ev"\r
644 pn$(7) = "p\81hap\84ev"\r
645 \r
646 prt = &H37A\r
647 prt2 = &H378\r
648 hist(1) = 10000\r
649 hist(2) = 10000\r
650 hist(3) = 10000\r
651 \r
652 FOR a = 1 TO 16\r
653 bitt(a) = 1\r
654 NEXT a\r
655 modee = 2\r
656 vilgu = 0\r
657 tul(1) = 1\r
658 tul(2) = 1\r
659 END SUB\r
660 \r
661 SUB sync\r
662 OPEN "sync.txt" FOR INPUT AS #1\r
663 LINE INPUT #1, a$\r
664 DATE$ = a$\r
665 LINE INPUT #1, a$\r
666 TIME$ = a$\r
667 CLOSE #1\r
668 \r
669 heli 2\r
670 END SUB\r
671 \r
672 SUB sync2\r
673 a$ = TIME$\r
674 a$ = LEFT$(a$, 5)\r
675 b = VAL(RIGHT$(a$, 2))\r
676 c = VAL(LEFT$(a$, 2))\r
677 IF b >= 30 THEN c = c + 1\r
678 b = 0\r
679 IF c > 23 THEN c = c - 24\r
680 a$ = RIGHT$(STR$(c), LEN(STR$(c)) - 1)\r
681 b$ = RIGHT$(STR$(b), LEN(STR$(b)) - 1)\r
682 IF LEN(a$) < 2 THEN a$ = "0" + a$\r
683 IF LEN(b$) < 2 THEN b$ = "0" + b$\r
684 a$ = a$ + ":" + b$\r
685 \r
686 'LOCATE 10, 1\r
687 'PRINT a$\r
688 \r
689 TIME$ = a$\r
690 \r
691 heli 1\r
692 END SUB\r
693 \r