Keskustelu: Koodit: QB: Tikittävä kello kertoo myös viikonpäivän

'Tämä on vanha kellopeli jonka tein joskus viime syksynä.
'Oli jännää nähdä näyttääkö se oikeaa viikonpäivää vielä
'karkauspäivän jälkeenkin, ja kun näytti niin päätin heittää
'sen nettiin

'Siis tämä ohjelma ympyrän ja tietynlaisen viivan piirtämistä
  DEFSNG A-Z: DECLARE SUB CreateMeter (x, y, Radius, LineColor)
    DECLARE SUB DrawCircle (x, y, Radius, CircleColor)
    DECLARE SUB Meter (Value, x, y, Radius, LineColor)
    DECLARE SUB Pause (DelayTime#)
    DECLARE SUB Clock ()
    DECLARE SUB Colors ()
    DECLARE SUB SetRGB (BaseColor!, Red!, Green!, Blue!)
    DECLARE SUB Range (Variable!, Min!, Max!)
    DECLARE SUB Center (Prompt AS STRING, Row!)
    DECLARE FUNCTION WDay (DateString AS STRING)

  'Tässä on prosenteissa kellon koko. Pelkkä feikkizoomi mutta toimii
     CONST Zoom = 100

 'SUB Meter:
     'Value:     Asteluku
     'x and y:   Navan koordinaatit
     'Radius:    Viivan pituus
     'LineColor: ja väri

 'SUB DrawCircle parameters:
     'x and y:   Navan koordinaatit
     'Radius:    Ympyräisen säde (halkaisija on 2 * säde)

 'FUNCTION WDay (DateString AS STRING):
  'Alkeellinen mutta yllättävän nopea ja toimiva subi joka kertoo viikonpäivän
  '"Lauantain" voi muuttaa vaikka "makkaraksi", se on tuolla DATAssa
     'DateString on päivämäärä QBasicmuodossa eli kk-pp-vvvv


 TYPE Counter
  x AS SINGLE
  y AS SINGLE
  Value AS SINGLE
  Radius AS SINGLE
  LineColor AS SINGLE
 END TYPE

  DIM SHARED Mtr(1 TO 10)     AS Counter
  DIM SHARED LastMtr(1 TO 10) AS Counter
   DIM SHARED MtrCount
   DIM SHARED WdCheckDelay

 'Värit
   CONST BackColor = 0, TableColor = 1, BorderLightSide = 2, BorderDarkSide = 3
   CONST TIMERColor = 4, SecColor = 5, MinColor = 6, HourColor = 7, LineColor = 8
   CONST BrightTextColor = 9, TextColor = 10, DarkTextColor = 11

 'Joka päivälle eri teksti
   DATA Maanantai, Tiistai, Keksiviikko, Torstai, Perjantai, Lauantai, Sunnuntai

 SCREEN 12


  Clock


 SCREEN 0: WIDTH 80, 25: COLOR 7
  LOCATE 23, 2: PRINT "Eikö ollutkin nätti?"

  CLOSE : SYSTEM: END: STOP  'Halusin varmistaa että ohjelma todella
                               'tulee sulkeutumaan ;)

 'Keksittää tekstin 80 * 32 näytölle
SUB Center (Prompt AS STRING, Row) : LOCATE Row, 41 - (LEN(Prompt) / 2): PRINT Prompt: END SUB

SUB Clock

 'Printtaa uskomattoman ja henkeäsalpaavan upean rivin näytön alalaitaan
   COLOR DarkTextColor: Center "Tehty 3.8.2003, Ihmemies McEronen Software", 30
   COLOR BrightTextColor: Center "(j)CLOCK versio 2.02", 1: COLOR TextColor: LOCATE 1, 30: PRINT "(": LOCATE 1, 32: PRINT ")": LOCATE 1, 41: PRINT "ersio"


 Colors

        DrawCircle 320, 240, Zoom, TableColor
        PAINT (319, 239), TableColor

     'Piirrä nupit joka tunnille, siis ne hassut viivat jotka
     'jakaa kellon reunat 12 sektoriin
       FOR h = 1 TO 12: Meter h * 30, 319, 239, Zoom * .99, LineColor: NEXT

     'Täytä keskusta pohjavärillä
       FOR Clr = 15 TO TableColor STEP TableColor - 15: DrawCircle 319, 239, Zoom * .9, Clr: PAINT (319, 239), Clr: NEXT

     'Piirrä rengas ja sen vario
       DrawCircle 320, 240, Zoom, BorderDarkSide
       DrawCircle 319, 239, Zoom, BorderLightSide


  'Viisarit kohdalleen
     CreateMeter 319, 239, Zoom * .47, MinColor
     CreateMeter 319, 239, Zoom * .8, HourColor
     CreateMeter 319, 239, Zoom * .89, SecColor
     CreateMeter 319, 239, Zoom * .27, TIMERColor


 DO

   'Päivitä arvot
     t$ = TIME$: D$ = DATE$
      s = (VAL(RIGHT$(t$, 2))) * 6
      m = (VAL(MID$(t$, 4, 2)) + (s / 600)) * 6
      h = (VAL(LEFT$(t$, 2)) + (m / 600)) * 30
       Mtr(1).Value = h
       Mtr(2).Value = m
       Mtr(3).Value = s
       Mtr(4).Value = TIMER
        COLOR DarkTextColor: Center t$, 8

     y$ = RIGHT$(D$, LEN(D$) - 6)
     m$ = LEFT$(D$, 2)
     D$ = MID$(D$, 4, 2)
       COLOR TextColor: Center D$ + "." + m$ + "." + y$, 7

     'Tsekkaa viikonpäivä ja printta se
       WdCheckDelay = WdCheckDelay - 1
       IF WdCheckDelay < 0 THEN WdCheckDelay = 1000: RESTORE: FOR D = 1 TO WDay(DATE$): READ WeekDay$: NEXT: Center WeekDay$, 6

   'Liikuta viisareita
     FOR i = 1 TO MtrCount
      IF Mtr(i).Value <> LastMtr(i).Value THEN

       'Pyyhi vanhat viivat pois silmistä
         Meter LastMtr(i).Value, LastMtr(i).x, LastMtr(i).y, LastMtr(i).Radius, TableColor

       'Piirrä kellolle viikset
         Meter Mtr(i).Value, Mtr(i).x, Mtr(i).y, Mtr(i).Radius, Mtr(i).LineColor

       'Itseään kunnioittavan kellon pitää pitää tikittää
         IF i = 1 THEN SOUND 37, .03

      END IF
     NEXT

   'Myöhempää käyttöä varten
     FOR i = 1 TO MtrCount
      LastMtr(i).Value = Mtr(i).Value
      LastMtr(i).x = Mtr(i).x
      LastMtr(i).y = Mtr(i).y
      LastMtr(i).Radius = Mtr(i).Radius
     NEXT


 LOOP UNTIL INKEY$ = CHR$(27)


END SUB

SUB Colors

    'SetRBG Väri,     PUN, VIHR, SIN
       SetRGB BackColor, 0, 10, 10
      SetRGB TableColor, 5, 10, 15
 SetRGB BorderLightSide, 10, 50, 50
  SetRGB BorderDarkSide, 10, 40, 40
      SetRGB TIMERColor, 10, 20, 20
        SetRGB SecColor, 5, 40, 25
        SetRGB MinColor, 5, 40, 25
       SetRGB HourColor, 5, 40, 25
       SetRGB LineColor, 20, 40, 50
 SetRGB BrightTextColor, 0, 60, 60
       SetRGB TextColor, 0, 45, 45
   SetRGB DarkTextColor, 0, 20, 20

END SUB

SUB CreateMeter (x, y, Radius, LineColor)

 MtrCount = MtrCount + 1
  Mtr(MtrCount).x = x
  Mtr(MtrCount).y = y
  Mtr(MtrCount).Radius = Radius
  Mtr(MtrCount).LineColor = LineColor


END SUB

SUB DrawCircle (x, y, Radius, CircleColor)

  Lastx = x + Radius: Lasty = y
  FOR Angle = 0 TO 2 * 3.141593 STEP .02
   Cx = Radius * COS(Angle) + x
   Cy = Radius * SIN(Angle) + y
   LINE (Lastx, Lasty)-(Cx, Cy), CircleColor
    Lastx = Cx: Lasty = Cy
  NEXT

END SUB

SUB Meter (Value, x, y, Radius, LineColor)

 'Piirtää viivan kulman laskennan periaatteiden mukaisesti
 '(huhhuh mikä lausehirviö)
   Angle = Value * (3.141593 / 180) - 1.570796
  Lx = Radius * COS(Angle) + x: Ly = Radius * SIN(Angle) + y
  LINE (x, y)-(Lx, Ly), LineColor

END SUB

DEFDBL A-Z
SUB Pause (DelayTime)

 StartTime = TIMER
 WHILE Time < StartTime + DelayTime: Time = TIMER
  IF INKEY$ = CHR$(27) THEN END
 WEND

END SUB

DEFSNG A-Z
SUB Range (Variable, Min, Max)

 IF Variable < Min THEN Variable = Min
 IF Variable > Max THEN Variable = Max

END SUB

SUB SetRGB (BaseColor, Red, Green, Blue)

 Range Red, 0, 63: Range Green, 0, 63: Range Blue, 0, 63
 OUT &H3C8, BaseColor: OUT &H3C9, Red: OUT &H3C9, Green: OUT &H3C9, Blue


END SUB

FUNCTION WDay (DateString AS STRING)

  'Tästä olen joskus ollut ylpeä

     Ty = VAL(RIGHT$(DateString, LEN(DateString) - 6))
     Tm = VAL(LEFT$(DateString, 2))
     Td = VAL(MID$(DateString, 4, 2))
     D = 1: m = 1: y = 2000: Wd = 6: LeapYear = 1

 DO: D = D + 1: Wd = Wd + 1: IF Wd > 7 THEN Wd = 1
  SELECT CASE m
   CASE 1, 3, 5, 7, 8, 10, 12
    IF D > 31 THEN D = 1: m = m + 1
   CASE 4, 6, 9, 11
    IF D > 30 THEN D = 1: m = m + 1
   CASE 2
    IF LeapYear = 1 AND D > 29 THEN D = 1: m = m + 1 ELSE IF D > 28 AND NOT LeapYear = 1 THEN D = 1: m = m + 1
  END SELECT
  IF m > 12 THEN m = 1: y = y + 1: LeapYear = LeapYear - 1
  IF LeapYear < 1 THEN LeapYear = 4
  IF y > Ty THEN Wd = 0: EXIT DO
 LOOP UNTIL D = Td AND m = Tm AND y = Ty
  WDay = Wd


END FUNCTION