Przykłady programów w języku QBASIC

 
'Program Totek.bas
CLS
PRINT "Losowanie numerow Totolotka - 6 z 49"
INPUT "Podaj liczbe mniejsza niz 32000 "; A
RANDOMIZE A
PRINT "Oto numery TOTOLOTKA na ten tydzien"
FOR i = 1 TO 6
 PRINT INT(RND * 50)
NEXT i
--------------------------------------
 
'Program zamliter.bas 
' Deklaracja funkcji
DECLARE FUNCTION znaki$ (a$)
 
CLS
PRINT "Program zamienia litery male na duze"
INPUT "Podaj malymi lterami imie i nazwisko: "; a$
PRINT
PRINT "Wczytalem "; a$
a$ = znaki$(a$) 'funkcja znaki$ zamienia litery male na duze
PRINT
PRINT "Po wykonaniu zamiany liter ", a$
END
 
FUNCTION znaki$ (a$)
nl = LEN(a$)
FOR i = 1 TO nl
b$ = MID$(a$, i)
nb = ASC(b$)
IF nb >= 97 AND nb <= 122 THEN
  MID$(a$, i) = CHR$(nb - 32)
END IF
100 NEXT i
znaki$ = a$
END FUNCTION

 
'PROGRAMY GEODEZYJNE

'1) WCIECIE KATOWE W PRZOD

' program wckat.bas - wersja QBasic
' Wersja szkolna

' Deklaracje procedur SUB i zmiennych
 DECLARE SUB wydruk ()
DECLARE SUB dane ()
DECLARE SUB wc ()
DECLARE SUB oblicz ()
DEFDBL P, R, W-Y ' Deklaracja zmiennych rzeczywistych podwójnej przecycji
DEFINT I-J, M    ' Deklaracja zmiennych calkowitych
DEFLNG N	 	
REM Wspolne zmienne - dzielone
COMMON SHARED a, b, x, y, rg, f$, xa, ya, xb, yb, mw, mk, Na, Nb
REM Format wydruku
f$ = "#############.###"
 
m = 100
pi = 4# * ATN(1#)
rg = 200# / pi
REM Numeracja od 1 (normalnie od 0)
OPTION BASE 1
REM Deklaracja tablic
DIM SHARED nr(m), w(m, 2), alfa(m), beta(m)
 
' Program glowny
CLS
PRINT "     Wciecie katowe w przod "
PRINT "       (C)  K. R. "
PRINT "      Wersja szkolna "
PRINT
REM Wywolanie procedur
CALL dane
CALL wydruk
END   ' Program glowny
 
 
'Procedury
 
SUB dane
PRINT
INPUT "Nr , X, Y  pktu nawiazania A (prawego) "; Na, xa, ya
INPUT "Nr , X, Y  pktu nawiazania B (lewego)  "; Nb, xb, yb
PRINT
PRINT "Oznaczenia: Alfa - Kat na pkcie A,  Beta - na pkcie B "
PRINT
INPUT "Wersja katow: 1 - grady, 2 - stop,min,sek "; wk
PRINT "Ilosc wciec z bazy "; Na; "-"; Nb, : INPUT mw
PRINT "Podaj kolejno: Nr_pktu, Alfa, Beta ";
PRINT
FOR i = 1 TO mw
PRINT "Pkt wyznaczany nr "; i
 
IF wk = 1 THEN INPUT "Nr, Alfa[g], Beta[g] "; nr(i), alfa(i), beta(i)
IF wk = 2 THEN
 INPUT "Nr, A_st, A_mi, A_sek, B_st, B_mi, B-sek"; nr(i), a1, a2, a3, b1, b2, b3
  a = a1 + a2 / 60 + a3 / 3600: b = b1 + b2 / 60 + b3 / 3600
  a = a / .9: b = b / .9
  alfa(i) = a: beta(i) = b
 END IF
 
a = alfa(i): b = beta(i):
CALL wc
w(i, 1) = x
w(i, 2) = y
NEXT i
END SUB
 
 
'Wciecie
SUB wc
a = a / rg
b = b / rg
x1 = xa: y1 = ya
x2 = xb: y2 = yb
ca = COS(a) / SIN(a): cb = COS(b) / SIN(b)     ' ctg a, ctg b
PRINT "ctg A ="; ca; "  ctg B = "; cb
x = (x1 * cb + y1 + x2 * ca - y2) / (cb + ca)
y = (-x1 + y1 * cb + x2 + y2 * ca) / (cb + ca)
PRINT "x="; x; "  y="; y
INPUT a$
END SUB
 
 
SUB wydruk
CLS
INPUT "Nazwa pliku lub urzadz. wydruku (PRN-drukarka, SCRN: - ekran) "; fw$
CLS
OPEN "O", #1, fw$ ' Otwarcie pliku 
PRINT #1, "             WCIECIE KATOWE W PRZOD"		' Zapis  - wydruk do pliku
PRINT #1,
PRINT #1, "      Punkty nawiazania: A, B"
PRINT #1, "     Nr            X               Y"
PRINT #1, USING "###########"; Na;
PRINT #1, USING f$; xa; ya
PRINT #1, USING "###########"; Nb;
PRINT #1, USING f$; xb; yb
PRINT
PRINT #1, "       Punkty wyznaczone wcieciem w przod: "
PRINT #1, "     Nr            Alfa        Beta               X               Y  "
PRINT #1, "                 g  c  cc      g  c  cc                             "
PRINT #1,
 
FOR i = 1 TO mw
PRINT #1, USING "###########"; nr(i);
PRINT #1, USING "########.#####"; alfa(i); beta(i);
PRINT #1, USING f$; w(i, 1); w(i, 2)
NEXT i
PRINT #1,
PRINT #1, "     Schemat wciecia w przod:          C"
PRINT #1, "    Pomierzone: Alfa, Beta.                   "
PRINT #1, "                                  Beta    Alfa "
PRINT #1, "                                 B-----------A"
PRINT #1,
END SUB
 
 
 
 
'Program az1.bas
' Obliczenie azymutu ze współrzędnych - wersja 1
' Podaje sie współrzędnie 2 punktow
' x1, y1
' x2, y2
 
' Apostrof oznacza komentrarz
REM to tez komentarz
 
' Podstawienia  - obliczenia Pi i Ro
 pi = 4# * ATN(1#)         ' Obliczenie Pi
 rg = 200# / pi            ' Ro gradowe
 rs = 180# / pi            ' Ro stopniowe
 
CLS ' Kasowanie ekanu
 
' PRINT to wydruk na ekranie
PRINT "Oblliczenie azymutu ze wspolrzednych 2 punktow: "
PRINT "Dane: x1, y1,  x2, y2"
PRINT
 
' INPUT - wprowadzanie danych
INPUT "Podaj wspolrzed. pktu 1-go: x1 i y1 (oddzielone przecinkiem) "; x1, y1
INPUT "Podaj wspolrzed. pktu 2-go: "; x2, y2
 
' Obliczenia przyrostow
dx = x2 - x1            ' Obl. DX
dy = y2 - y1            ' Obl. DY
 
PRINT  ' Pusta linia
PRINT "Obliczenia i wydruki kontrolne - testowanie cwiartek wspolrzednych"
PRINT
 
' Obliczenie azymutu w radianach - warunki IF
 
IF dx = 0 THEN  ' 1)  Warunek gdy dx = 0
 
 PRINT "poczatek dx=0"  ' Wydruk
 IF dy > 0 THEN     ' 2) dy>0 T
   a = pi / 2
   ELSE
   a = 1.5 * pi
  END IF            ' 2)  Koniec dy >0
 PRINT "Koniec dx=0"
 
ELSE            ' dx <> 0
 PRINT "else - poczatek dx<>0"
a = ATN(dy / dx)
   IF dx < 0 THEN  ' 11) dx  <0
     a = a + pi
    ELSE          ' dx >0
      IF dy < 0 THEN  '12
       a = a + 2 * pi
      END IF          ' 12) dy <0
     PRINT "Koniec dx <> 0"
   END IF         '11  Koniec dx < 0
 
END IF        ' 1 dx <>0
 
' obliczenie azymutu w gradach i stopniach
 
d = SQR(dx * dx + dy * dy)' dlugosc
azg = a * rg
azs = a * rs
 
PRINT
PRINT
PRINT "Wyniki obliczen"
 
PRINT "dx = "; dx, " dy = "; dy
PRINT "d = "; SQR(dx ^ 2 + dy ^ 2)
PRINT "az [grad] = "; azg, ' Dzieki przecinkowi kontynuacja wydruku w linii
PRINT "az [stopn] = "; azs
PRINT
PRINT "Wydruki wynikow formatyzowane:"
PRINT "Dlugosc = ";
' Wydruk z formatowaniem - PRINT USING - ilosc miejsc przed kropka dzies. i po
PRINT USING "#####.###"; d
PRINT "Azymut = ";
PRINT USING "####.#####"; azg; : PRINT "[grad]"
PRINT
 
INPUT "Nacisnij Enter"; a$
' Koniec programu
' END - moze byc a nie musi bo nie ma procedur ani funkcji
 
 
 
REM Obliczenie azymutu met. czwartakow. 
' Program Az_czw.bas - wersja 2
DEFDBL A, D, P, R, X-Y     ' zmienne rzeczywiste podwojnej dokladnosci
pi = 4! * ATN(1!)
 rg = 200# / pi  : REM Ro w gradach, nizej RS stopniach
 rs = 180# / pi  
 
DO    
CLS
PRINT "Obliczenie azymutu przy pomocy czwartakow"
INPUT "x1 "; x1
INPUT "y1 "; y1
INPUT "x2 "; x2
INPUT "y2 "; y2
 
dx = x2 - x1
dy = y2 - y1
 
PRINT "dx="; dx
PRINT "dy="; dy
 
IF dx = 0 THEN
IF dy > 0 THEN
    az = pi / 2
   ELSE
   az = 1.5 * pi
  END IF
 
ELSE
czw = ATN(dy / dx)
czw = ABS(czw)
czwg = czw * rg
czws = czw * rs
PRINT "pi="; pi
PRINT "czwart="; czwg; "[grad] ="; czws; "[st]"
 
IF dx > 0 AND dy > 0 THEN cw = 1
IF dx < 0 AND dy > 0 THEN cw = 2
IF dx < 0 AND dy < 0 THEN cw = 3
IF dx > 0 AND dy < 0 THEN cw = 4
 
SELECT CASE cw
 CASE 1
  az = czw
  PRINT "cwiartka -> case="; cw
 CASE 2
   az = pi - czw
   PRINT 'cwiartka ->"case="; cw
 CASE 3
   az = pi + czw
    PRINT "cwiartka ->case="; cw
 CASE 4
   az = 2 * pi - czw
    PRINT "cwiartka ->case="; cw
 END SELECT
 
END IF
 
azg = az * rg
azs = az * rs
PRINT "dx = "; dx
PRINT "dy="; dy
PRINT "azg[grad]=";
PRINT USING "####.#####"; azg
PRINT "azs[st]  =";
PRINT USING "####.#####"; azs
INPUT "Koniec obliczeä: 1 - T /2  - N ==> "; koniec
PRINT
LOOP UNTIL koniec = 1
 
END
 
 
 
 
' Program DlugAzQB.bas  - nazwa programu - komentarz - apostrof lub REm
' program do obliczenia dlugosci i azymutu ze wspolrzednych 2 punktow
' Dane z klawiatury
' Apostrof oanzacza komentrz - linia nie jest uwzgledniana
' Komentarz moze byc tez poprzedzony slowem REM
REM To tez komentarz
 
' Deklaracje procedur (SUB) i funkci (Function)
DECLARE SUB czekaj (lancuch1$) ' Procedura
DECLARE SUB Dlugosci ()
DECLARE SUB Azymut ()
DECLARE SUB Dlfun ()
DECLARE FUNCTION dlug! (dx!, dy!)	' Funckcja
 
 
REM Wyciagniecie wartosci miesiaca, dnia i roku z systemowej funkci DATE$
' LEFT$ - lewa czesc lancucha, MID$ - srodek - tu poczwszy od 4 znaku, 2 zanaki
' RIGHT$ - prawa czesc lancucha znakow
 
mm$ = LEFT$(DATE$, 2): dd$ = MID$(DATE$, 4, 2): yy$ = RIGHT$(DATE$, 4)
' zlozenie daty: rok.mc.dzien
dato$ = yy$ + "." + mm$ + "." + dd$  ' data oblicz
 
' Format wdruku liczby - 5 miejsc przed kroka dzieietna, 3 po kropce
fk$ = "######.####"
 
' Przypisanie do zmiennek koniec wartosci 0
 
koniec = 0
 
CLS    ' Kasowanie ekranu
 PRINT "Data: "; dd$; "-"; mm$; "-"; yy$    ' wydruk daty na eranie
 PRINT   ' Pusty print na ekranie - linia pusta
 PRINT " Program DlugAzQB.bas"
 PRINT " Obliczenie dlugosci i azymutow ze wspolrzednych 2 punktow"
 PRINT "Dane z klawiatury"
 PRINT
 PRINT
 
 
DO      ' Poczatek petli DO - zewnetrznej
 
  DO    ' Poczatek drugiej petli - wewnetrznej
 
   PRINT "      0  Koniec obliczen "
   PRINT "      1  Dlugosci ze wspolrzednych"
   PRINT "      2  Azymut ze wspolrzednych"
   PRINT "      3  Dlugosc z funkcji"
   PRINT
   INPUT "Wybierz wariant: 0..3 ==>  "; iw  ' wprowadzanie wariantu wyboru opcji
 
  LOOP UNTIL iw >= 0 AND iw <= 3    ' koniec petli DO wewnetrznej
 
     SELECT CASE iw             ' Instruckja wyboru CASE
      CASE 0: koniec = -1
      CASE 1: CALL Dlugosci
      CASE 2: CALL Azymut
      CASE 3: CALL Dlfun        ' Koniec instruckji CASE
     END SELECT
 
 LOOP UNTIL koniec = -1         ' Koniec petli DO zewn.
 
 
 
CLS
 
END  'Koniec Programu  glownego
 
 
' -------------------Podprogramy --------------
 
SUB Azymut      ' podprogram azymut
 
 pi = 4# * ATN(1#)
 rg = 200# / pi
 rs = 180# / pi
' fk$ = "#####.####"
SHARED fk$
 
 CLS
 
 PRINT "Obliczenie azymutu ze wspolrzednych"
 
 ' Wprowadzenie wspolrzednych x1, y1;  x2, y2
 INPUT "x1 "; x1    ' wprowadzenie wzpolrz. x  pktu 1-go
 INPUT "y1 "; y1
 INPUT "x2 "; x2
 INPUT "y2 "; y2
 
' Obliczenie przyrostow
dx = x2 - x1
dy = y2 - y1
 
'Obliczenie azymutu w radianach
IF dx = 0 THEN  ' 1) dx = 0
 
  IF dy > 0 THEN     ' 2) dy>0 T
   a = pi / 2
   ELSE
   a = 1.5 * pi
  END IF            ' 2)  Koniec dy >0
 
 END IF ' 1) dx=0
 
 
IF dx <> 0 THEN    ' 10) dx <>0
 
 a = ATN(dy / dx)
 
   IF dx < 0 THEN  ' 11) dx  <0
     a = a + pi
    ELSE          ' dx >0
      IF dy < 0 THEN  '12
       a = a + 2 * pi
      END IF          ' 12) dy <0
   ' PRINT "Koniec dx <> 0"
    END IF         '11  Koniec dx < 0
 
END IF        ' 10 dx <>0
 
 
' Obliczenie azymutu w gradach i stopniach
azg = a * rg    ' Zamiana azymutu w radaianch na grady
azs = a * rs    ' Zamiana azymutu w radaianch na grady
 
' Wydruki
PRINT "dx = "; dx
PRINT "dy = "; dy
PRINT "Azymut azg=": PRINT USING fk$; azg: PRINT " [grad]"
PRINT "Azymut azs="; azs; " [stopni]"
PRINT "Odlegl z funkcji  = "; dlug(dx, dy);
PRINT
 
 
strD1$ = "Koniec obl. azymutu . Nacisnij enter" ' Podstawienie wartosci do lancucha
CALL czekaj(strD1$)     ' Wywolanie procedury czekaj
 
 
END SUB     ' Koniec procedury
 
SUB czekaj (lancuch1$)
 
 PRINT lancuch1$
 INPUT a$
 CLS
 
END SUB
 
' procedura Dlfun - dlugosc z funkcji
SUB Dlfun
CLS
PRINT "SUB Dlfun"
PRINT "Obliczenie dlugosci z funkcji Dlfun";
PRINT
INPUT "x1= "; x1
INPUT "y1= "; y1
INPUT "x2= "; x2
INPUT "y2= "; y2
 
 dx1 = x2 - x1
 dy1 = y2 - y1
 
odl = dlug(dx1, dy1)
PRINT "Odlegl = "; odl
INPUT a$
 
strD1$ = "Koniec obl. dlugosci z funkcji. Nacisnij enter"
 
CALL czekaj(strD1$)
 
END SUB
 
' funkcja dlug z parametrami dx i dy
FUNCTION dlug (dx, dy)
 
 d2 = dx * dx + dy * dy
 d = SQR(d2)
 dlug = d   ' W funkcji musi byc przypisanie wartosci do nazwy funckji przed wyjsciem
 
 ' Mozna by tez zrobic bezposrednio: dlug=SQR(dx^2+dy^2) - zamiast 3 linii powyzej
 
END FUNCTION
 
'Procedura Dlugosci - bez parametrow
SUB Dlugosci
CLS
 
 PRINT "Oblicenie dlugosci ze wspolrzednych "
 ' Wprowadzenie danych
 INPUT "x1= "; x1
 INPUT "y1= "; y1
 INPUT "x2= "; x2
 INPUT "y2= "; y2
 
' Obliczenie przyrostow dx i dy
 dx = x2 - x1
 dy = y2 - y1
 
 d1 = SQR(dx * dx + dy * dy)    ' Pierwsza met. oblicz. dlugosci
 d2 = SQR(dx ^ 2 + dy ^ 2)      ' Druga metoda
 
 PRINT
 PRINT "d1= "; d1
 PRINT "d2= "; d2
 
 PRINT
 strD1$ = "Koniec obl. dlugosci. Nacisnij enter"
 
CALL czekaj(strD1$)
 
END SUB     ' Koniec procedury
 
 ' Program DADPQB.bas
'Obliczenie dlugosci, azymutów i wspórzednych z domiarów prostokatnych i pola trojkata oraz wieloboku met Gaussa
' wersja QBasic
' Deklaracja procedur i funkcji
DECLARE SUB czekaj (lancuch1$)
DECLARE SUB SPRNR ()
DECLARE SUB Dlugosci ()
DECLARE SUB Azymut ()
DECLARE SUB Dlfun ()
DECLARE SUB Wspoldom ()
DECLARE SUB PTrojkata ()
DECLARE SUB Pole ()
DECLARE SUB NAZPLIK ()
DECLARE FUNCTION dlug# (dx#, dy#)
DECLARE FUNCTION azymg# (d#, dy#)


' Wyciagniecie danych daty
MM$ = LEFT$(DATE$, 2): DD$ = MID$(DATE$, 4, 2): YY$ = RIGHT$(DATE$, 4)
dato$ = YY$ + "." + MM$ + "." + DD$ ' data oblicz

il% = 1000 ' Max ilosc pktow
pi = 4# * ATN(1#) ' PI
rg = 200# / pi ' Ro gradowe
rs = 180# / pi ' Ro stopn

fk$ = "######.#####" ' Format zapisu katow
fp$ = "############" ' Format zapisu nrow (10 cyfr)

' OPTION BASE 1 ' Tablice numerowane od 1 (normalnie od 0)
DIM lnry(il%), xy(il%, 2) 'Deklaracja tablic: nrow oraz wspolrz: x,y

koniec = 0

CLS ' Kasowanie ekranu

PRINT "Data: "; DATo$; ' (" yyyy/mm/dd") ' Wydruk daty
PRINT
PRINT " Podstawowe obliczenia geodezyjne - wersja QBASIC"
PRINT "Obliczenie: dlugosci, azymutu, wspolrz. z domiarow, i pola ze wspolrz."

PRINT " Program DADPQB.bas"
PRINT
PRINT

PRINT

DO ' 1)

DO ' 2)

PRINT " 0 Koniec obliczen "
PRINT " 1 Dlugosci ze wspolrzednych"
PRINT " 2 Azymut ze wspolrzednych"
PRINT " 3 Dlugosc z funkcji"
PRINT " 4 Wspolrzedne z domiarow"
PRINT " 5 Pole trojkata"
PRINT " 6 Pole ze wspolrz. wzory Gaussa"
PRINT
INPUT "Wybierz wariant: 0..6 ==> "; iw
CLS
LOOP UNTIL iw >= 0 AND iw <= 6 '2)

SELECT CASE iw
CASE 0: koniec = -1
CASE 1: CALL Dlugosci
CASE 2: CALL Azymut
CASE 3: CALL Dlfun
CASE 4: CALL Wspoldom
CASE 5: CALL PTrojkata
CASE 6: CALL Pole
END SELECT

LOOP UNTIL koniec = -1 ' 1)


CLS

END 'Progr glow ==================

' Funkcja azymg - azymut wynikowy w gradach
FUNCTION azymg# (dx#, dy#)

pi = 4! * ATN(1!)
rg = 200! / pi
rs = 180! / pi

IF dx = 0 THEN ' 1) dx = 0

IF dy > 0 THEN ' 2) dy>0 T
a = pi / 2
ELSE
a = 1.5 * pi
END IF ' 2) Koniec dy >0

END IF ' 1) dx=0


IF dx <> 0 THEN ' 10) dx <>0

a = ATN(dy / dx)

IF dx < 0 THEN ' 11) dx <0
a = a + pi
ELSE ' dx >0
IF dy < 0 THEN '12
a = a + 2 * pi
END IF ' 12) dy <0
END IF '11 Koniec dx < 0

END IF ' 10 dx <>0


azg = a * rg

azymg# = azg

END FUNCTION

' Procedura azymut
SUB Azymut

pi = 4# * ATN(1#)
rg = 200! / pi
rs = 180! / pi

CLS

PRINT "Obliczenie azymutu ze wspolrzednych"

INPUT "x1 "; x1
INPUT "y1 "; y1

INPUT "x2 "; x2
INPUT "y2 "; y2

dx = x2 - x1
dy = y2 - y1


IF dx = 0 THEN ' 1) dx = 0

IF dy > 0 THEN ' 2) dy>0 T
a = pi / 2
ELSE
a = 1.5 * pi
END IF ' 2) Koniec dy >0

END IF ' 1) dx=0



IF dx <> 0 THEN ' 10) dx <>0

' PRINT "Poczatek dx<>0"

a = ATN(dy / dx)

IF dx < 0 THEN ' 11) dx <0
a = a + pi
ELSE ' dx >0
IF dy < 0 THEN '12
a = a + 2 * pi
END IF ' 12) dy <0
' PRINT "Koniec dx <> 0"
END IF '11 Koniec dx < 0

END IF ' 10 dx <>0


azg = a * rg
azs = a * rs

PRINT "dx = "; dx
PRINT "dy = "; dy
PRINT "Azymut azg="; azg; " [grad]"
PRINT "Azymut azs="; azs; " [stopni]"
PRINT "Odleglosc = "; SQR(dx * dx + dy * dy)

PRINT "Azymut z funkcji = "; azymg(dx#, dy#); "[grad]"
PRINT
strD1$ = "Koniec obl. azymutu . Nacisnij enter"

CALL czekaj(strD1$)


END SUB ' ----------------------

SUB czekaj (lancuch1$)

PRINT lancuch1$
INPUT a$
CLS

END SUB

SUB Dlfun ' -------------------------
CLS
PRINT "SUB Dlfun"
PRINT "Obliczenie dlugosci z funkcji Dlfun";
PRINT
INPUT "x1= "; x1
INPUT "y1= "; y1
INPUT "x2= "; x2
INPUT "y2= "; y2

dx1# = x2 - x1
dy1# = y2 - y1

odl# = dlug(dx1#, dy1#)
PRINT "Odlegl z funkcji dlug = "; odl#

PRINT "Azymut z funkcji azymg = "; azymg(dx#, dy#); "[grad]"
INPUT a$

strD1$ = "Koniec obl. dlugosci z funkcji. Nacisnij enter"

CALL czekaj(strD1$)

END SUB

FUNCTION dlug# (dx#, dy#)

'
d2# = dx# * dx# + dy# * dy#
' print "d2 z funkcji: ";d2
d# = SQR(d2#)
'print "d="; d#

dlug# = d#

END FUNCTION '--------------------------

SUB Dlugosci '----------
CLS

PRINT "Obliczenie dlugosci ze wspolrzednych "
INPUT "x1= "; x1
INPUT "y1= "; y1
INPUT "x2= "; x2
INPUT "y2= "; y2

dx = x2 - x1
dy = y2 - y1

d1 = SQR(dx * dx + dy * dy)
d2 = SQR(dx ^ 2 + dy ^ 2)
PRINT
PRINT "d1= "; d1
PRINT "d2= "; d2

PRINT "Azymut z funkcji = "; azymg(dx#, dy#); "[grad]"
PRINT
strD1$ = "Koniec obl. dlugosci. Nacisnij enter"

CALL czekaj(strD1$)
END SUB '------------------

SUB NAZPLIK 'Procedura na wprowadzenie pliku wynikow i dokl. wydruku
SHARED fx$, f$
20
CLS
PRINT " ELEMENTARNE OBLICZENIA GEODEZYJNE "
PRINT " Program DADPQB "

PRINT
PRINT
PRINT "Nazwa pliku/urzadzenia do wydruku wynikow: "
PRINT
PRINT "PRN lub LPT1 - drukarka 1, LPT2 - drukarka 2, "
PRINT "SCRN: lub <Enter> - ekran "
PRINT "Dowolna inna nazwa zgodnie z DOS - plik "
PRINT
PRINT "Podaj nazwe do wydruku wynikow i nacisnij <Enter> ==> "; ;
INPUT f$
IF f$ = "" THEN f$ = "scrn:"
OPEN f$ FOR OUTPUT AS 1
iwyd = 0
PRINT
DO
INPUT "Dokladnosc wydruku wspolrz: 2 lub 3 : "; iwyd
LOOP UNTIL iwyd = 2 OR iwyd = 3

IF iwyd = 3 THEN fx$ = "###########.###" ELSE fx$ = "###########.##"
PRINT #1, " ELEMENTARNE OBLICZENIA GEODEZYJNE "
PRINT #1,

PRINT #1,
PRINT #1,
CLS
END SUB

' Procedura - pole met. Gaussa
SUB Pole 'Oblicz pola ze wspolrz wzory Gaussa
SHARED lnr, ip, lnry(), xy(), spr, x, y, fk$, fp$, fx$, sprp, il%
il% = 1000
DIM ln(il%), px(il%), py(il%)

pi = 4# * ATN(1#)
rg = 200# / pi
rs = 180# / pi
fk$ = "######.#####" ' Format zapisu katow
fp$ = "############" ' Format zapisu nrow (10 cyfr)

CALL NAZPLIK ' Wywolanie funkcji


PRINT #1, " OBLICZENIE POLA POWIERZCHNI ZE WSPOLRZEDNYCH"
PRINT #1,
PRINT #1, " Lp Nr(i) X(i) Y(i) D(i)-(i+1) "
PRINT #1,

lnr = 1
np = 0: pO = 0: PP = 0: X0 = 0: Y0 = 0
FOR i = 1 TO iln%
ln(i) = 0
px(i) = 0
py(i) = 0
NEXT i

CLS
PRINT "Obliczenie pola powierzchni ze wspolrzednych "
PRINT
PRINT "Uwaga: Numery punktow - liczba max. 2147483647 (prakt. 9 cyfr) "
PRINT
PRINT " Dane (Nr X Y) : 1 - z klawiatury, 2 - ze zbioru: ";
INPUT idp

IF idp = 2 THEN
INPUT "Nazwa pliku danych "; fd$
OPEN "I", #2, fd$
INPUT #2, np
FOR i = 1 TO np
INPUT #2, ln(i), px(i), py(i)
NEXT i
CLOSE #2
END IF

IF idp = 1 THEN
PRINT "Uwaga: Numery punktow - liczba max. 2147483647 (prakt. 9 cyfr) "

INPUT "Ilosc punktow "; np

FOR i = 1 TO np
INPUT " Nr pktu "; lnr
CALL SPRNR
ln(i) = lnr
px(i) = x: py(i) = y
PRINT "X="; x, " Y="; y
ln(i) = lnr
NEXT i
END IF

px(np + 1) = px(1): py(np + 1) = py(1)
pO = 0

X0 = px(1): Y0 = py(1)

FOR i = 1 TO np
x1 = px(i) - X0: y1 = py(i) - Y0
x2 = px(i + 1) - X0: y2 = py(i + 1) - Y0
PP = x1 * y2 - y1 * x2: PP = PP / 2
pO = pO + PP
d = SQR((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1))
PRINT #1, i; TAB(5);
PRINT #1, USING fp$; ln(i);
PRINT #1, TAB(20);
PRINT #1, USING fx$; px(i); py(i); d

PRINT i; TAB(5);
PRINT USING fp$; ln(i);
PRINT TAB(20);
PRINT USING fx$; px(i); py(i); d

NEXT i

PRINT #1,
PRINT #1, " Ilosc punktow = "; np
PRINT #1, " Pole powierzchni = ";
PRINT #1, USING fx$; pO;
PRINT #1, " [m^2]"
PRINT " Ilosc punktow = "; np
PRINT " Pole powierzchni = ";
PRINT USING fx$; pO;
PRINT " [m^2]"

PRINT #1,
PRINT #1,
PRINT #1,

INPUT "Nacisnij Enter "; a$
END SUB

'Pole trojkat
SUB PTrojkata
CLS
PRINT "Obliczenie pola trojkata o podstawie a i wysokosci h"
PRINT
INPUT "Wariant danych: 1 - a i h, 2 - Boki a, b, c"; w
IF w = 1 THEN
INPUT "a = "; a
INPUT "h = "; h
s = a * h / 2
PRINT "Pole = "; a
ELSE
INPUT "a, b, c"; a, b, c
p = .5 * (a + b + c)
s = SQR(p * (p - a) * (p - b) * (p - c))
ha = 2 * s / a
hb = 2 * s / b
hc = 2 * s / c
PRINT "Wysokosc z boku a: Ha ="; ha
PRINT "Wysokosc z boku b: Hb="; hb
PRINT "Wysokosc z boku c: Hc="; hc
PRINT " Pole ="; s
END IF

PRINT " Pole trojkata [m2]"
PRINT USING "##########.##"; s
PRINT
INPUT "Nacisnij Enter "; a$
END SUB

SUB SPRNR 'Sprawdza czy jest punkt
SHARED x, y, spr, lnr, ip, lnry(), xy()
spr = 0
FOR i = 1 TO ip
' ? i,lnry(i),xy(i,1),xy(i,2)
IF lnry(i) = lnr THEN
spr = 1
x = xy(i, 1)
y = xy(i, 2)
PRINT "Jest pkt "; lnr
PRINT "X="; x, " y="; y
EXIT FOR
END IF
NEXT
IF spr = 0 THEN
ip = ip + 1
lnry(ip) = lnr
INPUT "X, Y ", x, y
xy(i, 1) = x
xy(i, 2) = y
PRINT "ip="; ip
END IF
END SUB

SUB Wspoldom 'Oblicz, wspol. z domiarow
fk$ = "######.#####" ' Format zapisu katow
fp$ = "############" ' Format zapisu nrow (10 cyfr)

' OPTION BASE 1 ' Tablice numerowane od 1 (normalnie od 0)
il% = 1000
DIM lnry(il%), xy(il%, 2) 'Deklaracja tablic: nrow oraz wspolrz: x,y

' PRINT "Podaj nazwe do wydruku wynikow i nacisnij <Enter> ==> "; ;
' INPUT f$
' IF f$ = "" THEN f$ = "scrn:"
' OPEN f$ FOR OUTPUT AS 1
' SHARED lnry(), xy()
PRINT " Obliczenie wspolrzednych z domiarow prostokatnych "
PRINT
PRINT " Nr pkt Odcieta Rzedna X Y "
PRINT
lnr = 1
DO WHILE lnr <> 0
CLS
PRINT "Nr punktu pocz A lub 0 gdy koniec obliczen "
INPUT "Nr pocz A: "; lnr
IF lnr <> 0 THEN
' CALL SPRNR
la = lnr
INPUT "Xa "; xa
' xa = x
INPUT "Ya "; ya
'ya = y
PRINT "Xa="; xa, " Ya="; ya
PRINT "Nr nr punktu konc B "
INPUT "Nr konc. B "; lnr
' CALL SPRNR
lb = lnr
INPUT "Xb "; xb
' xb = x
INPUT "Yb "; yb
' xb = x
' yb = y
PRINT " xa="; xa
PRINT " ya="; ya
PRINT " xb="; xb
PRINT " yb="; yb
dx1 = xb - xa
dy1 = yb - ya
PRINT "Dx="; dx1
PRINT "Dy="; dy1
dob = SQR(dx1 * dx1 + dy1 * dy1)
PRINT "dx="; dx1, " dy="; dy1, " Dobl="; dob
INPUT "Dlug. pomierz A-B "; dp
c = dx1 / dp: s = dy1 / dp
PRINT "c=Dx/Dp"; c, " s=Dy/Dp"; s
lnp = 1
DO WHILE lnp <> 0
' 200
PRINT "Nr punktu na domiarze prost. P lub 0 gdy koniec obliczen linii pomiar"
INPUT lnp
IF lnp <> 0 THEN
' CALL spr2(lnp)
' IF sprp = 1 GOTO 200
INPUT "Odcieta d: "; d
INPUT "Rzedna h: "; h
dx = c * d - h * s
dy = s * d + h * c
PRINT "dx="; dx, " dy="; dy
x = xa + dx
y = ya + dy
PRINT "Xp="; x, " Yp="; y
ip = ip + 1
' lnry(ip) = lnp
xy(ip, 1) = x
xy(ip, 2) = y
PRINT "Nr Pkt D H Xobl Yobl"

PRINT USING "#######"; lnp;
PRINT USING "#########.###"; d; h; x; y
END IF
LOOP
PRINT xb; yb
PRINT
PRINT "Dpom = "; dp
PRINT
PRINT " Dobl=";
PRINT dob
PRINT
PRINT
INPUT "Nacisnij Enter "; a$
END IF
LOOP
' CLOSE #1
END SUB '--------------

 
 

Inne programy 

 
REM p221.BAS
REM ========
REM Petle DO UNTIL
CLS
PRINT "I obl: DO UNTIL"
k = 0
DO UNTIL k = 20
 k = k + 1
 PRINT k
LOOP
INPUT "I obl "; A$
 
CLS
PRINT "I obl: DO UNTIL"
k = 0
DO
 k = k + 1
 PRINT k
LOOP UNTIL k = 20
INPUT "II obl "; A$
 
REM p222.BAS
REM =========
REM Petle DO WHILE
CLS
PRINT "I obl: DO WHILE... LOOP"
k = 0
DO WHILE k <= 20
 k = k + 1
 PRINT k
LOOP
INPUT "I obl DO WHILE "; A$
 
CLS
PRINT "II obl: DO ... LOOP WHILE"
k = 0
DO
 k = k + 1
 PRINT k
LOOP WHILE k <= 20
INPUT "II obl "; A$
 
REM ABCQ9.BAS - porzadkowanie liczb
REM =============
REM Uwaga! Linie z REM to komentarz – można pominąć
REM Program wczytuje n liczb i porządkuje
REM je od największej do najmniejszej
CLS
DIM liczba(50)  ‘ Tablica liczb rzeczywistych zwykłej precyzji na 50 pozycji
INPUT "Ile liczb "; n
FOR i = 1 TO n
  PRINT "Liczba nr "; i
  INPUT liczba(i)
NEXT i
REM porządkowanie liczb
FOR i = 1 TO n - 1
  FOR j = i + 1 TO n
    IF liczba(i) < liczba(j) THEN SWAP liczba(i), liczba(j)
  NEXT j
NEXT i
REM Wydruk uporządkowanych liczb
PRINT
PRINT "Liczby w porządku malejącym "
PRINT
FOR i = 1 TO n
 PRINT , liczba(i)
NEXT i
END
 
 
REM  Program ABCQ10.BAS
REM Program z wykorzystaniem FOR
REM Uwaga! Linie z REM to komentarz – można pominąć
REM Program wczytuje n nazwisk i porządkuje je od największej do najmniejszej
CLS
DIM nazw(50) AS STRING  ‘ deklaracja tablicy napisów na 5- pozycji
REM wprowadzenie nazwisk
INPUT "Ile nazwisk "; n
FOR i = 1 TO n
  PRINT "Nazwisko nr "; i
  INPUT nazw(i)
NEXT i
REM porządkowanie nazwisk
FOR i = 1 TO n - 1
  FOR j = i + 1 TO n
    IF nazw(i) > nazw(j) THEN SWAP nazw(i), nazw(j)
  NEXT j
NEXT i
REM Wydruk uporządkowanych nazwisk
PRINT
PRINT "Nazwiska w kolejności alfabetycznej "
PRINT
FOR i = 1 TO n
 PRINT , nazw(i)
NEXT i
END ‘ Koniec programu
 

 

 
REM abcq11.bas
REM =================
REM znajdowanie największej i najmniejszej liczby
CLS
DIM liczba(50)
INPUT "Ile liczb "; n
FOR i = 1 TO n
 PRINT "liczba nr "; i;
 INPUT liczba(i)
NEXT i
REM znajdowanie liczby największej
max = liczba(1)                                 '1
FOR i = 1 TO n
 IF liczba(i) > max THEN max = liczba(i)        '2
NEXT i
REM znajdowanie liczby najmniejszej             '3
min = liczba(1)
FOR i = 1 TO n
 IF liczba(i) < min THEN min = liczba(i)        '4
NEXT i
REM wydruk liczby max i minim.
PRINT
PRINT "Liczba największa = "; max, "Liczba najmniejsza="; min
END
 
REM abcq13.bas - z podprogramem
REM ==============
REM Podprogram drukuj – 2 wywołania
DECLARE SUB drukuj (x!): REM deklaracja procedury  ! oznacza single precision - real
CLS
a = 7
b = 15
CALL drukuj(a): REM Wywołanie procedury drukuj z parametrem aktualnym a
PRINT "Pierwszy powrót do programu głównego (Main)"
CALL drukuj(b): REM Wywołanie procedury drukuj z parametrem aktualnym b
PRINT "Drugi powrót do Main"
PRINT "w programie MAIN a="; a, "b="; b, "x="; x
END
 
SUB drukuj (x): REM procedura drukuj
PRINT "Jestem w podprogramie DRUKUJ ";
PRINT "x="; x, "a="; a, "b="; b
END SUB
 
 
REM ABCQ14.BAS
REM =================
REM 2 podprogramy: druk1 i druk2 
DECLARE SUB druk1 ()
DECLARE SUB druk2 ()
COMMON SHARED ws
CLS
ws = 23
PRINT "W programie głównym ws="; ws
 CALL druk1
 CALL druk2
END
 
SUB druk1
PRINT "w SUBroutine druk1 ws="; ws
END SUB
 
SUB druk2
PRINT "Tu także (w subroutine druk2)  ws="; ws
END SUB

REM abcq15.bas
REM Zmienne wspólne/współdzielone, podprogram (SUB) licz
DECLARE SUB licz ()
COMMON SHARED a, b, c, w
CLS
a = 1
b = 2
c = 3
PRINT "Przed wejściem do procedury LICZ wartości a, b, c oraz w (suma w licz): "
PRINT a, b, c, w
CALL licz
PRINT "Po wyjściu z proc LICZ wartości a, b, c oraz w (suma przed zmiana w licz): "
PRINT a, b, c, w
PRINT "Ponieważ a, b, c były zadeklarowane jako COMMON SHARED"
END
 
SUB licz
w = a + b + c
a = 10
b = 20
c = 30
END SUB
 
 
REM abcq16.bas
REM zmienne shared i zwykle, 2 podprogramy
DECLARE SUB ekran ()
DECLARE SUB pisz ()
CLS
a = 12
b = 20
PRINT "MAIN (główny) : a,b", a, b
CALL ekran
CALL pisz
 
SUB ekran
PRINT "ekran: a, b (zupełnie inne zmienne bo nie shared) "; a, b
END SUB
 
SUB pisz
SHARED a, b
PRINT "pisz: shared a, b", a, b
END SUB

 

REM p27.bas
REM Zastosowanie funkcji – FUNCTION nazwa (parametry)
DECLARE FUNCTION sumprz (a, b, c)
CLS
INPUT "Podaj 3 liczby "; a, b, c
PRINT "Suma dlug. przek prostop a,b,c= "; sumprz(a, b, c)
END
 
FUNCTION sumprz (a, b, c)
p1 = SQR(a ^ 2 + b ^ 2)
p2 = SQR(b ^ 2 + c ^ 2)
p3 = SQR(a ^ 2 + c ^ 2)
sumprz = 2 * (p1 + p2 + p3)
END FUNCTION

REM p27c.bas Funkcja iloraz
DECLARE FUNCTION iloraz (a, b)
CLS
INPUT "podaj 2 liczby x,y "; x, y
rez1 = iloraz(x, y)
rez2 = iloraz(33, 11)
rez3 = iloraz(x * y, x + y)
rez4 = iloraz(3 + x, y / 7)
PRINT "rez1=iloraz(x,y)="; rez1
PRINT "rez1=iloraz(33,11)="; rez2
PRINT "rez3=iloraz(x*y, x+y)="; rez3
PRINT "rez4=iloraz(3+x,y/7)="; rez4
 
FUNCTION iloraz (p, q)
iloraz = p / q
END FUNCTION

REM p254.bas 
DECLARE FUNCTION znaki$ (a$)
REM Zamina liter – Funkcja znaki
CLS
INPUT "Podaj imie i nazwisko "; a$
PRINT
PRINT "Wczytalem", , a$
a$ = znaki$(a$)           ' funkcja znaki$ zamienia litery male na duze
PRINT
PRINT "Po wykonaniu zamiany liter", a$
END
 
FUNCTION znaki$ (a$)
ni = LEN(a$)
FOR i = 1 TO ni
b$ = MID$(a$, i)
nb = ASC(b$)
IF nb >= 97 AND nb <= 122 THEN
 MID$(a$, i) = CHR$(nb - 32)
END IF
100 NEXT i
znaki$ = a$
END FUNCTION

REM p255.bas
DECLARE FUNCTION sumprz (a, b, c)
CLS
INPUT "Podaj 3 liczby "; a, b, c
PRINT "Suma dlug. przek prostop a,b,c= "; sumprz(a, b, c)
PRINT "p1, p2, p3 (shared w function sumprz) "; p1; "  "; p2; "  "; p3
END
 
FUNCTION sumprz (a, b, c)
SHARED p1, p2, p3
p1 = SQR(a ^ 2 + b ^ 2)
p2 = SQR(b ^ 2 + c ^ 2)
p3 = SQR(a ^ 2 + c ^ 2)
sumprz = 2 * (p1 + p2 + p3)
END FUNCTION
 
 
REM p256.bas
REM Wykorzystanie definicji funkci: DEF FN_nazwafunckcji(parametry)
CLS
PRINT "Poczatek programu z DEF FNnazwa"
c = 12
d = 32
e = c * d
REM ***** Definicja funkcji
  DEF FNiloczyn (a, b) = (a + b) * (a ^ 2 + b ^ 2) * (a ^ 3 + b ^ 3)
REM ***** Koniec definicji funkcji
a = 3
b = 4
PRINT " DEF FNiloczyn (a, b) = (a + b) * (a ^ 2 + b ^ 2) * (a ^ 3 + b ^ 3)"
PRINT "FNiloczyn (3,4)="; FNiloczyn(a, b)
END
 
REM p257.bas
CLS
PRINT "Definicja funkcji przez: DEF FNnazwa...END DEF"
 
REM ***** defin. funkcji
  DEF fniloczyn (a, b)
  p1 = (a + b)
  p2 = (a ^ 2 + b ^ 2)
  p3 = (a ^ 3 + b ^ 3)
  fniloczyn = p1 * p2 * p3
  END DEF
REM ***** Koniec definicji funkcji
 
PRINT "DEF FNiloczyn (a,b) jak na str 256"
PRINT "FNiloczyn(3,4)="; fniloczyn(3, 4)
 

REM p263a
REM Rownanie kwadratowe – krotki zapis programu
INPUT "a, b, c "; a, b, c
del = b ^ 2 - 4 * a * c
IF del < 0 THEN END
PRINT (b - SQR(del)) / 2 / a, (b + SQR(del)) / 2 / a