├── Beginners ├── LIM.PAS ├── MEMREC.PAS ├── MENU.PAS ├── MENU2.PAS ├── MENU3.PAS ├── PALINDR.PAS ├── PROCTYPE.PAS ├── QSORTARR.PAS ├── SORTLIST.PAS ├── SORTREC.PAS ├── SUPERPWD.PAS ├── TEMPLATE.PAS ├── TEMPLATE2.pas ├── TEST2.pas ├── arr_max.pas ├── lim2.pas ├── matrix_test.pas ├── mul_matr.pas ├── piechart.pas ├── pointertest.pas ├── unittree.pas ├── verb_num.pas └── xor_main.pas ├── Compression ├── COMPMARK │ ├── COMPFILE.PAS │ ├── COMPMARK.ASM │ ├── COMPMARK.OBJ │ ├── COMPMARK.PAS │ ├── DEMO.PAS │ ├── EXPFILE.PAS │ ├── TPALLOC.DOC │ └── TPALLOC.PAS ├── HUFFMAN │ ├── HUFFMAN.PAS │ └── UNHUFF.PAS ├── LRU │ ├── DECLARE.PAS │ ├── DICTNARY.PAS │ ├── IO_BYTE.PAS │ ├── IO_PTR.PAS │ ├── MAP.PAS │ ├── QUEUE.PAS │ ├── README.TXT │ ├── SQUEEZE.PAS │ └── UNSQUEEZ.PAS ├── LZH │ ├── LZH.PAS │ ├── LZH.TXT │ └── LZHTEST.PAS ├── LZSS │ ├── LZSS.PAS │ └── LZSS.TXT ├── LZW2 │ ├── BITFILE2.PAS │ ├── LZW2.PAS │ ├── OUTLINE.PAS │ └── readme.txt ├── PRESSKIT.TXT └── SIXPACK │ ├── SIXPACK.PAS │ └── SIXPACK.TXT ├── Data Structures ├── Arrays │ ├── BUBBLE.PAS │ ├── COMBINA.PAS │ ├── Median.pas │ ├── binary.pas │ ├── merge_Bose.PAS │ ├── merge_neuman.PAS │ ├── permut.pas │ ├── qsort.pas │ └── sortmerg.pas ├── Lists │ ├── Linklist.pas │ ├── deck_dyn.pas │ ├── deck_st.pas │ ├── fifo_dyn.pas │ ├── fifo_st.pas │ ├── hash_dbl.pas │ ├── hash_dyn.pas │ ├── hash_lin.pas │ ├── linkprocs.pas │ ├── list.pas │ ├── preem.pas │ ├── queue_sort.PAS │ ├── sort.pas │ ├── sort_bintree.pas │ ├── sort_ins.pas │ ├── sort_ss.pas │ ├── sort_stack.pas │ └── sortlinkedlist.pas └── Trees │ ├── TREE.PAS │ ├── avl_tree.pas │ ├── avltree.pas │ └── redblack.pas ├── Files ├── Dirtree.pas ├── Dirtree2.pas ├── Dirtree3.pas ├── Dirtree4.pas ├── Dos Navigator │ ├── ADVANCE.PAS │ ├── ARCHIVER.PAS │ ├── ARCVIEW.PAS │ ├── ARVID.PAS │ ├── ASCIITAB.PAS │ ├── BPC.CFG │ ├── BUILD.BAT │ ├── BUILDDN.BAT │ ├── CALC.PAS │ ├── CCALC.PAS │ ├── CDPLAYER.PAS │ ├── CDUTIL.PAS │ ├── CELLSCOL.PAS │ ├── CMDLINE.PAS │ ├── COLORS.PAS │ ├── COLORSEL.PAS │ ├── COLORVGA.PAS │ ├── COMLNK.PAS │ ├── COMLNKIO.PAS │ ├── COMMANDS.PAS │ ├── COPY.PAS │ ├── CPUTYPE.ASM │ ├── DBLWND.PAS │ ├── DBVIEW.PAS │ ├── DBWATCH.PAS │ ├── DIALOGS.PAS │ ├── DISKIMG.PAS │ ├── DISKINFO.PAS │ ├── DISKTOOL.PAS │ ├── DN.ASM │ ├── DN.DEF │ ├── DN.PAS │ ├── DNAPP.PAS │ ├── DNFORMAT.PAS │ ├── DNHELP.PAS │ ├── DNSTDDLG.PAS │ ├── DNUTIL.PAS │ ├── DRIVERS.PAS │ ├── DRIVES.PAS │ ├── EDITOR.PAS │ ├── ERASER.PAS │ ├── EXTRAMEM.PAS │ ├── FBB.PAS │ ├── FILECOPY.PAS │ ├── FILEFIND.PAS │ ├── FILELIST.PAS │ ├── FILESCOL.PAS │ ├── FIXER.PAS │ ├── FLPANEL.PAS │ ├── FLPANELX.PAS │ ├── FLTOOLS.PAS │ ├── FMTUNIT.PAS │ ├── FORMAT.ASM │ ├── FORMAT.PAS │ ├── FSTORAGE.PAS │ ├── FVIEWER.PAS │ ├── GAUGE.PAS │ ├── GAUGES.PAS │ ├── GETCONST.PAS │ ├── GETCPU.ASM │ ├── HELPFILE.PAS │ ├── HELPKERN.PAS │ ├── HIDEVIEW.PAS │ ├── HISTLIST.PAS │ ├── HISTRIES.PAS │ ├── IDLERS.PAS │ ├── INIFILES.PAS │ ├── LINK.INC │ ├── LINKTYP.PAS │ ├── LINKUTIL.PAS │ ├── LZWC2.ASM │ ├── LZWD2.ASM │ ├── MACRO.PAS │ ├── MEMINFO.PAS │ ├── MEMORY.PAS │ ├── MENUS.PAS │ ├── MESSAGES.PAS │ ├── MICROED.PAS │ ├── MODEMIO.PAS │ ├── NAVYLINK.PAS │ ├── OBJECTS.PAS │ ├── OBJTYPE.PAS │ ├── OVERLAYS.PAS │ ├── PAR.PAS │ ├── PHONES.PAS │ ├── PRINTMAN.PAS │ ├── RCP.INI │ ├── RCP.PAS │ ├── README.TXT │ ├── REANIMAT.PAS │ ├── RESOURCE │ │ ├── ENGLISH │ │ │ ├── DN.DNL │ │ │ ├── DN.DNR │ │ │ └── DNHELP.HTX │ │ └── RUSSIAN │ │ │ ├── DN.DNL │ │ │ ├── DN.DNR │ │ │ └── DNHELP.HTX │ ├── RSR.BAT │ ├── RSTRINGS.PAS │ ├── RUNCMD.INC │ ├── SBLOCKS.PAS │ ├── SCROLLBK.PAS │ ├── SCROLLER.PAS │ ├── SETUPS.PAS │ ├── STARSKY.PAS │ ├── STARTUP.PAS │ ├── STDEFINE.INC │ ├── STRINGS.PAS │ ├── SWE.PAS │ ├── SYSINT.ASM │ ├── TERMINAL.PAS │ ├── TETRIS.PAS │ ├── TREE.PAS │ ├── TVHC.PAS │ ├── UNIWIN.PAS │ ├── USERMENU.PAS │ ├── UUCODE.PAS │ ├── UUE2INC.ASM │ ├── VALIDATE.PAS │ ├── VERSION.INC │ ├── VERSION.PAS │ ├── VGA33.ASM │ ├── VIEWS.PAS │ ├── WINCLP.PAS │ ├── XDBLWND.PAS │ ├── XMSSTRM.INC │ ├── XTIME.PAS │ └── _MHZ.ASM └── Windows │ ├── LFN.PAS │ └── NATLFN.PAS ├── Graphics ├── BMPWRITE │ ├── BMPWRITE.PAS │ ├── EGAVGA.BGI │ ├── TESTBMP.EXE │ └── TESTBMP.PAS ├── Color │ ├── HSI │ │ ├── HSI.DOC │ │ ├── HSI.PAS │ │ └── VGA256.PAS │ └── RGB2HLS │ │ ├── RGB2HLS.MSG │ │ └── RGB2HLS.PAS ├── JULIASET.PAS ├── PCX │ ├── PCX16.PAS │ ├── PCX256.PAS │ └── TESTSAVE.PAS └── SVGA │ ├── SVGADRV.OBJ │ ├── SVGA_.PAS │ ├── USE_SVGA.PAS │ └── VGA256.PAS ├── Hacker ├── PROTECT.pas ├── Scr_cop2.pas ├── Scr_copy.pas ├── bruteforce.pas └── xor_rec.pas ├── Lib ├── CYRILLIC.PAS ├── DEBUG.INC ├── KEYCODE.INC ├── OVR_INIT.PAS ├── STR2NUM.INC ├── STRUTIL.PAS ├── bcdto.pas ├── bits.inc └── err_trap.pas ├── Math ├── 8DIGITS.PAS ├── ALLMATHS.PAS ├── Calculus │ ├── ANALIZE │ │ ├── ANALIZE.MSG │ │ └── ANALIZE.PAS │ ├── CALCLEN.PAS │ ├── CALCULUS.PAS │ ├── SURFACES.PAS │ ├── TESTCALC.PAS │ └── approx.pas ├── Checksum │ ├── ADLER.PAS │ ├── ADLER32.PAS │ ├── CRC32.PAS │ └── ZCONF.INC ├── Discrete │ └── srhbranch.pas ├── FunctionParser │ ├── FParser.pas │ ├── TSTPARS.pas │ └── readme.txt ├── Geometry │ ├── 3DMISC.PAS │ ├── CURVES.PAS │ └── poly.pas ├── Optimization │ ├── LABA0.TXT │ ├── LABA1.TXT │ ├── LABA2.TXT │ ├── OPT3_.PAS │ └── OPTIM.TXT ├── REVERSE_NUM.PAS ├── ROOTS.PAS ├── Statistics │ ├── NORMRAND.PAS │ ├── NRAND.TXT │ ├── NRAND0.PAS │ ├── NRAND1.PAS │ └── NRAND2.PAS ├── chebyshev_polinom.pas └── frac.pas ├── README.md ├── Sound └── OCTAVE.PAS ├── Translators └── TPTC │ ├── ATOI.INC │ ├── CRT.UNS │ ├── FTOA.INC │ ├── GETENV.INC │ ├── GRAPH.UNS │ ├── ITOA.INC │ ├── KEYPRESS.INC │ ├── LJUST.INC │ ├── STOUPPER.INC │ ├── TPCDECL.INC │ ├── TPCEXPR.INC │ ├── TPCMISC.INC │ ├── TPCSCAN.INC │ ├── TPCSTMT.INC │ ├── TPCSYM.INC │ ├── TPCUNIT.INC │ ├── TPTC.PAS │ ├── TPTCMAC.H │ ├── TPTCSYS.PAS │ ├── TPTCSYS.UNS │ └── UNINC.PAS └── User Interface ├── DOS Fonts ├── HEBEGA.CPI ├── HEB_8X16.FNT ├── HEB_8X16.OBJ ├── HEB_8X8.FNT ├── PARSECPI.PAS ├── RUS.PAS ├── RUS_8X16.FNT ├── RUS_8X16.OBJ ├── SCRIBBLE.OBJ └── TESTRUS.PAS └── Turbo Vision ├── APPLPRO.PAS ├── BPRINT.PAS ├── DESK.PAS ├── DIALL.PAS ├── DIRLIST.PAS ├── EXTRABAR.PAS ├── FLARRAYS.PAS ├── FM.PAS ├── FOCUS.PAS ├── GENREBOX.PAS ├── GROWVIEW.PAS ├── HELPTEST.PAS ├── LAYOUT.PAS ├── MATRIX.PAS ├── MULSEL.PAS ├── MULTISEL.PAS ├── NUMINPUT.PAS ├── OBJECTS.INT ├── PASSWD.PAS ├── PASSWD2.PAS ├── POPUP.PAS ├── SETBOX.PAS ├── SORTWORD.PAS ├── STRARRAY.PAS ├── STROBJ.PAS ├── STUFF.PAS ├── TCOLLECT.PAS ├── TESTINP.PAS ├── TESTPWD.PAS ├── TESTSEL.PAS ├── TSORTLST.PAS ├── TVINPUT.PAS ├── TVMOUSE.PAS ├── TV_MISC.PAS ├── TV_STUD ├── LIST.DAT ├── STUDOBJ.PAS ├── TV_OBJ.PAS ├── TV_STUD.PAS ├── WORK_DB.PAS └── list.txt └── USEOBJ.PAS /Beginners/LIM.PAS: -------------------------------------------------------------------------------- 1 | 2 | const 3 | eps = 1e-8; // точность 4 | 5 | function Power (base: double; N: integer): double; 6 | // степень N по основанию base 7 | var k: integer; 8 | P: double; 9 | begin 10 | P := 1.0; 11 | for k := 1 to N do 12 | P := P * base; 13 | 14 | Power := P; 15 | end; 16 | 17 | var 18 | n: integer; 19 | xold, 20 | xnew: double; 21 | 22 | begin 23 | xnew := 0.0; 24 | n := 1; 25 | repeat 26 | xold := xnew; 27 | xnew := Power (1.0 + 1.0/n, n); 28 | writeln ('limit:', xnew : 20 : 8, ' itteration: ', n); 29 | inc (n); 30 | until abs (xnew - xold) < eps; 31 | 32 | writeln ('limit is (approximately):', xnew : 20 : 8); 33 | readln; 34 | end. 35 | -------------------------------------------------------------------------------- /Beginners/MEMREC.PAS: -------------------------------------------------------------------------------- 1 | type 2 | TRec = record 3 | Name: string[40]; 4 | Price: integer; 5 | end; 6 | PRec = ^TRec; 7 | 8 | var 9 | F: file of TRec; 10 | Rec: PRec; 11 | CreateDB: boolean; 12 | qnt: word; 13 | 14 | 15 | procedure Init; 16 | begin 17 | Assign (F, 'input.dat'); 18 | {$I-} 19 | Reset (F); 20 | {$I+} 21 | CreateDB := IOresult <> 0; 22 | if CreateDB then 23 | begin 24 | Rewrite (F); 25 | 26 | write ('Enter quantity of products: '); readln (qnt); 27 | end; 28 | end; 29 | 30 | procedure Output; 31 | begin 32 | writeln; 33 | writeln ('- Product': 40, '- Price':10); 34 | while not EOF (F) do 35 | with Rec^ do 36 | begin 37 | read (F, Rec^); 38 | writeln (Name: 40, Price: 10); 39 | end; 40 | end; 41 | 42 | procedure Create; 43 | var 44 | i: word; 45 | 46 | begin 47 | for i := 1 to qnt do 48 | with Rec^ do 49 | begin 50 | writeln; 51 | write ('Enter product name (up to 40 chars): '); readln (Name); 52 | write ('Enter price of product: '); readln (Price); 53 | 54 | write (F, Rec^); 55 | end 56 | end; 57 | 58 | begin 59 | Init; 60 | 61 | New (Rec); 62 | 63 | if CreateDB then 64 | Create 65 | else 66 | Output; 67 | 68 | Dispose (Rec); 69 | 70 | Close (F); 71 | end. -------------------------------------------------------------------------------- /Beginners/MENU.PAS: -------------------------------------------------------------------------------- 1 | uses crt; 2 | 3 | var c: char; 4 | 5 | Procedure Menu; 6 | begin 7 | ClrScr; 8 | writeln('=== Главное Меню ===' ); 9 | writeln(' 1. item 1'); 10 | writeln(' 2. item 2'); 11 | writeln(' 3. item 2'); 12 | writeln(' 0. Exit') ; 13 | c:=readkey; 14 | end; 15 | 16 | begin 17 | Menu; 18 | 19 | writeln; 20 | case c of 21 | '1': writeln('item 1'); 22 | '2': writeln('item 2'); 23 | '3': writeln('item 3'); 24 | '0': exit; 25 | end; 26 | end. -------------------------------------------------------------------------------- /Beginners/MENU2.PAS: -------------------------------------------------------------------------------- 1 | uses CRT; 2 | 3 | const 4 | MaxOptions = 5; 5 | width = 6; {Max length of string} 6 | optText: array [1..MaxOptions] of string[width] = 7 | ('item 1', 8 | 'item 2', 9 | 'item 3', 10 | 'item 4', 11 | 'item 5'); 12 | 13 | optNormal = LightGray; 14 | optSelected = Yellow; 15 | 16 | var 17 | X, Y, 18 | selected, { Index of item, selected by color at start } 19 | row: byte; 20 | 21 | procedure MakeMenu; 22 | var 23 | i: byte; 24 | begin 25 | ClrScr; 26 | Y := row; 27 | for i := 1 to MaxOptions do 28 | begin 29 | GoToXY (X, Y); 30 | if i = selected then 31 | TextColor (optSelected) 32 | else 33 | TextColor (optNormal); 34 | write (optText[i]); 35 | inc (Y, 2); 36 | end; 37 | end; 38 | 39 | function Choice: byte; 40 | var 41 | ch: char; 42 | begin 43 | selected := 1; 44 | X := (80 - width) div 2; 45 | row := (25 - MaxOptions) div 2; 46 | repeat 47 | MakeMenu; 48 | ch := readkey; 49 | if ch = #0 then 50 | ch := readkey; 51 | case ch of 52 | #80: {Down} 53 | begin 54 | inc (Selected); 55 | if Selected > MaxOptions then 56 | Selected := 1; 57 | MakeMenu; 58 | end; 59 | 60 | #72: {Up} 61 | begin 62 | dec (Selected); 63 | if Selected = 0 then 64 | Selected := MaxOptions; 65 | MakeMenu; 66 | end; 67 | end; 68 | until ch = #13; {Enter} 69 | Choice := Selected; 70 | end; 71 | 72 | var 73 | Option: byte; 74 | 75 | begin 76 | Option := Choice; 77 | TextColor (LightGray); 78 | clrscr; 79 | writeln (optText[option]); 80 | readln; 81 | end. -------------------------------------------------------------------------------- /Beginners/MENU3.PAS: -------------------------------------------------------------------------------- 1 | uses CRT; 2 | 3 | Type 4 | MenuType = (Vertical, Horizontal); 5 | 6 | const 7 | MaxItems = 5; { Max of items in menu } 8 | width = 6; { Max length of items } 9 | optText: array [1..MaxItems] of string[width] = 10 | ('item 1', 11 | 'item 2', 12 | 'item 3', 13 | 'item 4', 14 | 'item 5'); 15 | 16 | optNormal = LightGray; 17 | optSelected = Yellow; 18 | 19 | var 20 | X, Y, 21 | selected, { Index of item, selected by color at start } 22 | row: byte; 23 | 24 | procedure MakeMenu; 25 | var 26 | i: byte; 27 | begin 28 | ClrScr; 29 | Y := row; 30 | for i := 1 to MaxItems do 31 | begin 32 | GoToXY (X, Y); 33 | if i = selected then 34 | TextColor (optSelected) 35 | else 36 | TextColor (optNormal); 37 | write (optText[i]); 38 | inc (Y, 2); 39 | end; 40 | end; 41 | 42 | function Choice: byte; 43 | var 44 | ch: char; 45 | begin 46 | selected := 1; 47 | X := (80 - width) div 2; 48 | row := (25 - MaxItems) div 2; 49 | repeat 50 | MakeMenu; 51 | ch := readkey; 52 | if ch = #0 then 53 | ch := readkey; 54 | case ch of 55 | #80: {Down} 56 | begin 57 | inc (Selected); 58 | if Selected > MaxItems then 59 | Selected := 1; 60 | MakeMenu; 61 | end; 62 | 63 | #72: {Up} 64 | begin 65 | dec (Selected); 66 | if Selected = 0 then 67 | Selected := MaxItems; 68 | MakeMenu; 69 | end; 70 | end; 71 | until ch = #13; {Enter} 72 | Choice := Selected; 73 | end; 74 | 75 | var 76 | Option: byte; 77 | 78 | begin 79 | Option := Choice; 80 | 81 | TextColor (LightGray); 82 | clrscr; 83 | writeln (optText[option]); 84 | readln; 85 | end. -------------------------------------------------------------------------------- /Beginners/PALINDR.PAS: -------------------------------------------------------------------------------- 1 | 2 | function IsPalindrom(S: string): boolean; 3 | var i,len: integer; 4 | pal: boolean; 5 | begin 6 | pal:=true; 7 | 8 | len:=length(S); 9 | for i:=1 to (len div 2) do 10 | if S[i]<>S[len-i+1] then 11 | begin 12 | pal:=false; 13 | break; 14 | end; 15 | 16 | IsPalindrom:=pal 17 | end; 18 | 19 | var Str: string; 20 | begin 21 | write('Enter string: '); 22 | readln(str); 23 | writeln('Palindrom: ',IsPalindrom(str)); 24 | readln; 25 | end. -------------------------------------------------------------------------------- /Beginners/PROCTYPE.PAS: -------------------------------------------------------------------------------- 1 | program Using_procedural_types; 2 | 3 | type 4 | Proctype = function (x: real): real; 5 | 6 | function MyFunc (x: real): real; far; 7 | begin 8 | MyFunc := x * x 9 | end; 10 | 11 | function MyFunc2 (x: real): real; far; 12 | begin 13 | MyFunc2 := x * x 14 | end; 15 | 16 | procedure X (P: pointer); 17 | var F: Proctype; 18 | begin 19 | @F := P; 20 | writeln (F (15.1) : 10 : 2) 21 | end; 22 | 23 | var F: Proctype; 24 | begin 25 | writeln; 26 | 27 | F := Myfunc; 28 | writeln (F (23.7) : 10 : 2); 29 | 30 | x (@Myfunc); 31 | end. -------------------------------------------------------------------------------- /Beginners/SORTLIST.PAS: -------------------------------------------------------------------------------- 1 | 2 | uses Objects; 3 | 4 | procedure Print(C: PCollection); 5 | 6 | procedure PrintWord(P : PString); far; 7 | begin 8 | Writeln(P^); 9 | end; 10 | 11 | begin 12 | Writeln(#13#10'List of students:'#13#10); 13 | C^.ForEach(@PrintWord); 14 | end; 15 | 16 | const 17 | FileName = 'students.txt'; 18 | 19 | var 20 | WordList: PCollection; 21 | F: Text; 22 | str: string; 23 | 24 | begin 25 | Assign(F, FileName); 26 | {$I-} 27 | Reset(F); 28 | {$I+} 29 | if IOResult <> 0 then 30 | begin 31 | writeln('Error: can''t open ',FileName); 32 | halt(1); 33 | end; 34 | 35 | WordList := New(PStringCollection, Init(10, 5)); 36 | if WordList=nil then halt(2); 37 | 38 | while Not EOF(F) do 39 | begin 40 | readln(F,str); 41 | WordList^.Insert(NewStr(str)); 42 | end; 43 | Close(F); 44 | 45 | Print(WordList); 46 | Dispose(WordList, Done); 47 | end. -------------------------------------------------------------------------------- /Beginners/SORTREC.PAS: -------------------------------------------------------------------------------- 1 | program SortRec; 2 | 3 | const N = 4; 4 | type 5 | TInfo = record 6 | Name: string [40]; 7 | Age: integer; { возраст } 8 | end; 9 | 10 | List = array [1..N] of TInfo; { массив записей содержит возраст и имя } 11 | 12 | var 13 | F: file of TInfo; 14 | Rec: Tinfo; 15 | I: Integer; 16 | 17 | begin { Main } 18 | 19 | Assign (F, 'shop.dat'); 20 | rewrite (F); 21 | { заполнение массива записей } 22 | for I := 1 to N do 23 | with Rec do 24 | begin 25 | writeln; 26 | write ('Enter name: '); readln (Name); 27 | write ('Enter age: '); readln (Age); 28 | write (F, Rec); 29 | end; 30 | 31 | Close (F); 32 | (* 33 | { форматированный вывод на экран массива записей } 34 | writeln; 35 | writeln ('Name' : 40, 'Age' : 10); 36 | for I := 1 to 40 do write ('='); 37 | writeln; 38 | 39 | for I := 1 to N do 40 | with rec do 41 | begin 42 | write ( I : 2 ); 43 | write ( ' ' : 4, Name); 44 | writeln ( Age : 44 - Length (Name)); 45 | end; 46 | 47 | readln;*) 48 | end. 49 | -------------------------------------------------------------------------------- /Beginners/SUPERPWD.PAS: -------------------------------------------------------------------------------- 1 | Unit SuperPWD; 2 | 3 | Interface 4 | Uses Dos; 5 | 6 | Type 7 | TOperation = (Encode, Decode); 8 | 9 | Const 10 | Success = 0; 11 | Fail = -1; 12 | 13 | Function Encrypt (fn: pathstr): integer; {Returns status Success/Fail} 14 | Function Decrypt (fn: pathstr): integer; {Returns status Success/Fail} 15 | 16 | Implementation 17 | 18 | procedure XORstr (var z: string); 19 | var 20 | k: byte; 21 | begin 22 | for k := 1 to length (z) do 23 | z[k] := chr( ord (z[k]) xor k); 24 | end; 25 | 26 | Procedure FixExtension (Var s: pathstr; h:String); 27 | begin 28 | s := copy (s, 1, pos ('.', s)) + h; 29 | end; 30 | 31 | Function XORfile (fn: pathstr; op: TOperation): integer; 32 | var 33 | F, F2: text; 34 | s: string; 35 | 36 | begin 37 | XORfile := Success; 38 | 39 | Assign (F, fn); 40 | {$I-} 41 | reset (F); 42 | {$I+} 43 | 44 | if IOresult = 0 then 45 | begin 46 | if op = Decode then 47 | FixExtension (fn, 'txt') 48 | else 49 | FixExtension (fn, 'pwd'); 50 | 51 | Assign (F2, fn); 52 | {$I-} 53 | rewrite (F2); 54 | {$I+} 55 | while Not EOF (F) do 56 | begin 57 | readln (F, s); 58 | XORstr (s); 59 | {$I-} 60 | writeln (F2, s); 61 | {$I+} 62 | if IOresult <> 0 then 63 | begin 64 | XORfile := Fail; 65 | break; 66 | end; 67 | end; 68 | close (F2); 69 | end; 70 | close (F); 71 | end; 72 | 73 | Function Encrypt (fn: pathstr): integer; 74 | begin 75 | Encrypt := XORfile (fn, Encode); 76 | end; 77 | 78 | Function Decrypt (fn: pathstr): integer; 79 | begin 80 | Decrypt := XORfile (fn, Decode); 81 | end; 82 | 83 | end. -------------------------------------------------------------------------------- /Beginners/TEMPLATE.PAS: -------------------------------------------------------------------------------- 1 | 2 | type 3 | PListObject = ^TListObject; 4 | TListObject = object 5 | prev,next: PListObject; 6 | constructor Init; 7 | procedure PrintItem; virtual; 8 | end; 9 | 10 | PIntList = ^TIntList; 11 | TIntList = object (TListObject) 12 | data: integer; 13 | constructor Init; 14 | procedure PrintItem; virtual; 15 | procedure AddItem (num: integer); 16 | end; 17 | 18 | 19 | var 20 | top: PIntList; 21 | 22 | 23 | constructor TListObject.Init; 24 | begin 25 | end; 26 | 27 | 28 | procedure TListObject.PrintItem; 29 | begin 30 | end; 31 | 32 | 33 | procedure TIntList.PrintItem; 34 | begin 35 | write (data: 4); 36 | end; 37 | 38 | 39 | constructor TIntList.Init; 40 | begin 41 | Inherited Init 42 | end; 43 | 44 | procedure TIntList.AddItem (num: integer); 45 | var newelem: PIntList; 46 | begin 47 | newelem := new(PIntList, Init); (* Создать в памяти новый элемент *) 48 | newelem^.data:=num; 49 | newelem^.next:=top; (* Присоединить к этому элементу список *) 50 | top:=newelem; (* Вернуть его, как начало нового списка *) 51 | end; 52 | 53 | 54 | procedure PrintList (List: PListObject); 55 | begin 56 | if (list=NIL) then (* Если список пуст *) 57 | writeln ('Список пуст!') (* Сообщить об этом *) 58 | else 59 | while (list<>NIL) do (* Пока текущий элемент списка не последний *) 60 | begin 61 | List^.PrintItem; 62 | list:=list^.next; (* Перейти к следующему элементу *) 63 | end; 64 | end; 65 | 66 | var 67 | IntList : PIntList; 68 | begin 69 | top := nil; 70 | IntList := New (PIntList, Init); 71 | IntList^.AddItem (10); 72 | IntList^.AddItem (9); 73 | IntList^.AddItem (8); 74 | PrintList (top); 75 | Dispose (Intlist); 76 | readln; 77 | end. 78 | -------------------------------------------------------------------------------- /Beginners/TEMPLATE2.pas: -------------------------------------------------------------------------------- 1 | 2 | type 3 | PListObject = ^TListObject; 4 | TListObject = object 5 | prev,next: PListObject; 6 | constructor Init; 7 | procedure PrintItem; virtual; 8 | end; 9 | 10 | TData = record 11 | n: integer; 12 | s: string; 13 | end; 14 | 15 | PRecList = ^TRecList; 16 | TRecList = object (TListObject) 17 | data: TData; 18 | constructor Init; 19 | procedure PrintItem; virtual; 20 | procedure AddItem (num: integer); 21 | end; 22 | 23 | 24 | var 25 | top: PRecList; 26 | 27 | 28 | constructor TListObject.Init; 29 | begin 30 | end; 31 | 32 | 33 | procedure TListObject.PrintItem; 34 | begin 35 | end; 36 | 37 | 38 | procedure TRecList.PrintItem; 39 | begin 40 | write (data.n: 4); 41 | end; 42 | 43 | 44 | constructor TRecList.Init; 45 | begin 46 | Inherited Init 47 | end; 48 | 49 | procedure TRecList.AddItem (num: integer); 50 | var newelem: PRecList; 51 | begin 52 | newelem := new(PRecList, Init); (* Создать в памяти новый элемент *) 53 | newelem^.data.n:=num; 54 | newelem^.next:=top; (* Присоединить к этому элементу список *) 55 | top:=newelem; (* Вернуть его, как начало нового списка *) 56 | end; 57 | 58 | function searchel (data: Tdata): PRecList; 59 | var 60 | list:PRecList; 61 | begin 62 | list := top; 63 | if (list<>NIL) then (* Если список не пуст *) 64 | begin 65 | while 66 | ((list^.next<>NIL) and 67 | (list^.data.n<>data.n)) do (* Пока текущий элемент не последний и не искомый *) 68 | list:=list^.next; (* Переходить к следующему элементу списка *) 69 | if (list^.data.n<>data.n) then (* Если искомый элемент не найден*) 70 | searchel:=NIL (*вернуть указатель на пустой список *) 71 | else (* Иначе *) 72 | searchel:=list; (* Вернуть указатель на этот элемент *) 73 | end 74 | else (* Иначе *) 75 | begin 76 | searchel:=NIL; (* Вернуть указатель на пустой список *) 77 | end; 78 | end; 79 | 80 | 81 | procedure PrintList (List: PListObject); 82 | begin 83 | if (list=NIL) then (* Если список пуст *) 84 | writeln ('Список пуст!') (* Сообщить об этом *) 85 | else 86 | while (list<>NIL) do (* Пока текущий элемент списка не последний *) 87 | begin 88 | List^.PrintItem; 89 | list:=list^.next; (* Перейти к следующему элементу *) 90 | end; 91 | end; 92 | 93 | var 94 | RecList : PRecList; 95 | begin 96 | top := nil; 97 | RecList := New (PRecList, Init); 98 | RecList^.AddItem (10); 99 | RecList^.AddItem (9); 100 | RecList^.AddItem (8); 101 | PrintList (top); 102 | Dispose (Reclist); 103 | readln; 104 | end. 105 | -------------------------------------------------------------------------------- /Beginners/TEST2.pas: -------------------------------------------------------------------------------- 1 | 2 | Program Max_search; 3 | 4 | Const m = 10; 5 | 6 | Type vector = array[1..m] Of integer; 7 | 8 | Var a: vector; 9 | i,j,imax,max,p,d: integer; 10 | n: real; 11 | Begin 12 | randomize; 13 | writeln('Nicaaiea ianneaa e aai auaia'); 14 | For i:=1 To m Do 15 | Begin 16 | p := random(20); 17 | a[i] := p-1; 18 | write(a[i]:3); 19 | End; 20 | max := a[1]; 21 | For i:=2 To m Do 22 | If max grOk then 35 | Halt(1); 36 | x := GetMaxX div 2; 37 | y := GetMaxY div 2; 38 | 39 | _From := 0; { Начальный угол сектора равен нулю } 40 | DrawPie (p1); 41 | DrawPie (p2); 42 | DrawPie (p3); 43 | 44 | Readln; 45 | CloseGraph; 46 | end. -------------------------------------------------------------------------------- /Beginners/pointertest.pas: -------------------------------------------------------------------------------- 1 | type 2 | PInfo = ^TInfo; { указатель на тип TInfo} 3 | TInfo = record 4 | Size, 5 | Len: integer; 6 | ss: string[20]; 7 | end; 8 | 9 | Arr = array[1..10] of word; 10 | PArr = ^Arr; { указатель на тип Arr} 11 | 12 | PInteger = ^Integer; { указатель на тип Integer } 13 | 14 | var 15 | i: integer; 16 | PInt: PInteger; 17 | PI: PInfo; 18 | PA: PArr; 19 | 20 | begin 21 | 22 | writeln; 23 | 24 | PInt := New (PInteger); { выделение памяти под указатель на тип Integer } 25 | PInt^ := 123; { значению по адресу PInt зададим значение } 26 | writeln ('Value = ', PInt^); 27 | Dispose (PInt); { освобождение зарезервированной памяти } 28 | 29 | writeln; 30 | 31 | PA := New (PArr); { выделение памяти под указатель на тип Arr } 32 | for i := 1 to 10 do PA^[i] := i * 2 - 1; { значениям массива по адресу PA зададим значения } 33 | for i := 1 to 10 do write (PA^[i] : 4); { выведем элементы массива по адресу PA } 34 | Dispose (PA); { освобождение зарезервированной памяти } 35 | 36 | writeln; 37 | writeln; 38 | 39 | PI := New (PInfo); { выделение памяти под указатель на тип TInfo} 40 | with PI^ do { заносим данные в запись по адресу PI } 41 | begin 42 | writeln ('Enter some information'); 43 | { вводим значения переменных в записи } 44 | write ('Size: '); readln (Size); 45 | write ('Length: '); readln (Len); 46 | write ('String: '); readln (ss); 47 | 48 | writeln; 49 | { выводим их значения } 50 | writeln ('Size: ', Size : 20); 51 | writeln ('Length: ', Len : 18); 52 | writeln ('String: ', ss : 18); 53 | end; 54 | Dispose (PI); { освобождение зарезервированной памяти после использования записи } 55 | 56 | end. -------------------------------------------------------------------------------- /Beginners/verb_num.pas: -------------------------------------------------------------------------------- 1 | Program verbal_number; 2 | {Дано целое число в диапазоне 100-999. Вывести строку-словесное описание данного 3 | числа, например:256-"двести пятьдесят шесть", 814-"восемьсот четырнадцать".} 4 | 5 | const 6 | 7 | c1: array [1..9] of string[6] = ( 8 | 'один', 9 | 'два', 10 | 'три', 11 | 'четыре', 12 | 'пять', 13 | 'шесть', 14 | 'семь', 15 | 'восемь', 16 | 'девять' 17 | ); 18 | 19 | c11: array [0..9] of string[12] = ( 20 | 'десять', 21 | 'одиннадцать', 22 | 'двенадцать', 23 | 'тринадцать', 24 | 'четырнадцать', 25 | 'пятнадцать', 26 | 'шестнадцать', 27 | 'семнадцать', 28 | 'восемнадцать', 29 | 'девятнадцать' 30 | ); 31 | 32 | c20: array [2..9] of string[9] = ( 33 | 'двадцать', 34 | 'тридцать', 35 | 'сорок', 36 | 'пятьдесят', 37 | 'шестьдесят', 38 | 'семьдесят', 39 | 'восемьдесят', 40 | 'девяносто' 41 | ); 42 | 43 | c100: array [1..9] of string[9] = ( 44 | 'сто', 45 | 'двести', 46 | 'триста', 47 | 'четыреста', 48 | 'пятьсот', 49 | 'шестьсот', 50 | 'семьсот', 51 | 'восемьсот', 52 | 'девятьсот' 53 | ); 54 | 55 | 56 | var x,y,z: String; 57 | s1,s2,s3:Char; 58 | begin 59 | WriteLn; 60 | Write ('Введите целое число в диапазоне (100-999): '); 61 | ReadLn (s1, s2, s3); 62 | 63 | x := c100 [ord(s1) - ord('0')]; 64 | 65 | if s2 = '1' then 66 | begin 67 | y := c11 [ord(s3) - ord('0')]; 68 | z := ''; 69 | end 70 | else 71 | if s2 <> '0' then 72 | begin 73 | y := c20 [ord(s2) - ord('0')]; 74 | if s3 <> '0' then 75 | z := c1 [ord(s3) - ord('0')] 76 | else 77 | z := ''; 78 | end 79 | else 80 | begin 81 | y := ''; 82 | if s3 <> '0' then 83 | z := c1 [ord(s3) - ord('0')] 84 | else z := ''; 85 | end; 86 | 87 | WriteLn('Словесное описание: ', x+' '+y+' '+z); 88 | readln; 89 | end. -------------------------------------------------------------------------------- /Beginners/xor_main.pas: -------------------------------------------------------------------------------- 1 | 2 | uses crt; 3 | 4 | Const 5 | BlockSize = 512; 6 | 7 | type 8 | TBuffer = array [0..BlockSize-1] of byte; 9 | 10 | var 11 | buffer: TBuffer; 12 | f: file; 13 | 14 | procedure FillMemo(Buf: TBuffer; Key: word); 15 | var i: word; 16 | c: char; 17 | begin 18 | i:=0; 19 | while i<=SizeOf(Buf) do 20 | begin 21 | c := chr(Buf[i] xor Key); 22 | if c<>#7 then write(c); 23 | Inc(i); 24 | end; 25 | writeln(#13#10,Key) 26 | end; 27 | 28 | var 29 | Key: word; 30 | Cnt: longint; 31 | begin 32 | If ParamCount<>1 then exit; 33 | Assign(F, ParamStr(1)); 34 | {$I-} 35 | reset(f,1); 36 | {$I+} 37 | if IOresult <> 0 then 38 | halt (3); 39 | BlockRead(F, Buffer, SizeOf(Buffer), Cnt); 40 | close(f); 41 | 42 | Key:=0; 43 | repeat 44 | clrscr; 45 | 46 | FillMemo(Buffer, Key); 47 | inc(key); 48 | if Key=255 then break; 49 | until Readkey=#27; 50 | end. 51 | -------------------------------------------------------------------------------- /Compression/COMPMARK/COMPFILE.PAS: -------------------------------------------------------------------------------- 1 | {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V+} 2 | {$M 8192,0,655360} 3 | Program CompFile; 4 | { This is a simple minded test program which uses COMPMARK to compress a file. 5 | This is intended as a demonstration of the objects in COMPMARK, not as a 6 | serious file compression program. See the comments in COMPMARK for 7 | information on appropriate use of these objects. } 8 | Uses CompMark, Dos, Crt; 9 | Const 10 | BufferSize = 20000; { Input buffer size } 11 | BufferPad = 5000; { Output buffer is this much bigger than input buffer } 12 | DefaultBits = 6; { If COMPBITS not specified, start with 6 } 13 | ReadMode = $20; { Deny Write, Read access for input file } 14 | Var 15 | InBuffer : Pointer; 16 | InFile : File; 17 | OutFile : CompFileOut; 18 | InName, OutName : String; 19 | 20 | Procedure Initialize; 21 | Var 22 | MaxMemory : LongInt; 23 | i, j : Word; 24 | ch : Char; 25 | Bits : Byte; 26 | OldMode : Byte; 27 | s : String[3]; 28 | Begin 29 | MaxMemory := MaxAvail - 2 * BufferSize - BufferPad; 30 | Bits := DefaultBits; 31 | s := GetEnv('COMPBITS'); 32 | If s <> '' Then Begin 33 | Val(s, i, j); 34 | If (j = 0) And (i <= 8) Then Bits := i; 35 | End; 36 | While (Bits > 0) And (WorkAreaSize(Bits) > MaxMemory) Do Dec(Bits); 37 | WriteLn('Using ', Bits, ' Bits, work area size is ', WorkAreaSize(Bits)); 38 | InitCompress(Bits); 39 | GetMem(InBuffer, BufferSize); 40 | {$I-} 41 | If ParamCount > 0 Then InName := ParamStr(1) Else Begin 42 | Write('Enter input file name: '); 43 | ReadLn(InName); 44 | End; 45 | OldMode := FileMode; 46 | FileMode := ReadMode; 47 | Assign(InFile, InName); 48 | Reset(InFile, 1); 49 | FileMode := OldMode; 50 | {$I+} 51 | If IoResult <> 0 Then Begin 52 | WriteLn('Unable to open input file ', InName); 53 | Halt(1); 54 | End; 55 | If ParamCount > 1 Then OutName := ParamStr(2) Else Begin 56 | Write('Enter output file name: '); 57 | ReadLn(OutName); 58 | End; 59 | WriteLn('COMPFILE will compress ', InName, ' to ', OutName); 60 | Write('OK? (Y/N): '); 61 | ch := UpCase(ReadKey); 62 | Write(ch, ' '); 63 | If ch <> 'Y' Then Begin 64 | WriteLn('Program terminated'); 65 | Halt(1); 66 | End; 67 | OutFile.Init(OutName, BufferSize + BufferPad); 68 | WriteLn(MemAvail, ' bytes free space remains'); 69 | Write('Working'); 70 | End; 71 | 72 | Procedure WriteCompressedBuffer; 73 | Var 74 | Len : LongInt; 75 | Begin 76 | Len := FileSize(InFile) - FilePos(InFile); 77 | If Len > BufferSize Then Len := BufferSize; 78 | BlockRead(InFile, InBuffer^, Len); 79 | OutFile.PutRecord(InBuffer^, Len); 80 | Write('.'); 81 | End; 82 | 83 | Begin 84 | Initialize; 85 | While Not Eof(InFile) Do WriteCompressedBuffer; 86 | WriteLn; 87 | OutFile.Flush; 88 | WriteLn(InName, ' Compressed (', 89 | (FileSize(InFile) - FileSize(OutFile.CompFile)) * 100 90 | Div FileSize(InFile), '%)'); 91 | OutFile.Done; 92 | Close(InFile); 93 | WriteLn('Compression done'); 94 | End. -------------------------------------------------------------------------------- /Compression/COMPMARK/COMPMARK.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Compression/COMPMARK/COMPMARK.OBJ -------------------------------------------------------------------------------- /Compression/COMPMARK/DEMO.PAS: -------------------------------------------------------------------------------- 1 | {$R-,S-} 2 | 3 | program Demo; 4 | {-Demonstrates use of TPALLOC} 5 | 6 | uses 7 | TpAlloc; 8 | 9 | type 10 | LongPtr = ^LongInt; 11 | var 12 | I, Elements, ErrorCount : LongInt; 13 | LongArray : LongPtr; 14 | LongArrayAddr : LongInt; 15 | 16 | function GetElementPtr(I : LongInt) : LongPtr; 17 | {-Return a pointer to the I'th element of our 0-based array} 18 | begin 19 | {Notes: 20 | 1) Subtract 1 from I if array is 1-based. 21 | 2) LongArrayAddr could be replaced with 'Linear(LongArray)', but this 22 | is much faster.} 23 | GetElementPtr := LinearToPointer(LongArrayAddr+(I*SizeOf(LongInt))); 24 | end; 25 | 26 | function GetElement(I : LongInt) : LongInt; 27 | {-Return the I'th element of our 0-based array} 28 | begin 29 | GetElement := GetElementPtr(I)^; 30 | end; 31 | 32 | procedure PutElement(I, Value : LongInt); 33 | {-Set the I'th element of our 0-based array to Value} 34 | begin 35 | GetElementPtr(I)^ := Value; 36 | end; 37 | 38 | begin 39 | WriteLn('MaxAvail = ', MaxAvail); 40 | 41 | {allocate as large an array of longints as possible} 42 | Elements := MaxAvail div SizeOf(LongInt); 43 | HugeGetMem(LongArray, Elements * SizeOf(LongInt)); 44 | if LongArray = nil then begin 45 | WriteLn('Unable to allocate array of ', Elements, ' elements'); 46 | Halt(1); 47 | end; 48 | 49 | {this saves us from recomputing Linear(LongArray) repeatedly} 50 | LongArrayAddr := Linear(LongArray); 51 | 52 | {show memory status} 53 | WriteLn('Allocated ', Elements * SizeOf(LongInt), ' bytes'); 54 | WriteLn('MaxAvail = ', MaxAvail); 55 | WriteLn('Successfully allocated array of ', Elements, ' elements'); 56 | 57 | {initialize the array} 58 | WriteLn('Initializing array...'); 59 | for I := 0 to Elements-1 do 60 | PutElement(I, I); 61 | 62 | {validate the array contents} 63 | WriteLn('Validating array contents...'); 64 | ErrorCount := 0; 65 | for I := 0 to Elements-1 do 66 | if GetElement(I) <> I then begin 67 | WriteLn('Error at element ', I, ': should be ', I, ', is ', 68 | GetElement(I)); 69 | Inc(ErrorCount); 70 | end; 71 | 72 | {show status} 73 | if ErrorCount = 0 then 74 | WriteLn('No errors found') 75 | else 76 | WriteLn(ErrorCount, ' errors found'); 77 | 78 | {release the memory} 79 | WriteLn('Releasing memory...'); 80 | HugeFreeMem(LongArray, Elements * SizeOf(LongInt)); 81 | WriteLn('MaxAvail = ', MaxAvail); 82 | end. 83 |  -------------------------------------------------------------------------------- /Compression/COMPMARK/EXPFILE.PAS: -------------------------------------------------------------------------------- 1 | {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V+} 2 | {$M 8192,0,655360} 3 | Program ExpFile; 4 | { This is a simple minded test program which uses COMPMARK to expand a file 5 | created by COMPFILE. This program is intended as part of a demonstration 6 | of the objects in COMPMARK, not as a serious file compression program. 7 | See the comments in COMPMARK for information on appropriate use of these 8 | objects. } 9 | Uses CompMark, Dos, Crt; 10 | Const 11 | BufferSize = 20000; { Output buffer size } 12 | BufferPad = 5000; { Input buffer is this much bigger than output buffer } 13 | WriteMode = $11; { Exclusive, Write access for output file } 14 | Var 15 | OutBuffer : Pointer; 16 | OutFile : File; 17 | InFile : CompFileIn; 18 | InName, OutName : String; 19 | 20 | Procedure Initialize; 21 | Var 22 | ch : Char; 23 | OldMode : Byte; 24 | Begin 25 | GetMem(OutBuffer, BufferSize); 26 | If ParamCount > 0 Then InName := ParamStr(1) Else Begin 27 | Write('Enter input file name: '); 28 | ReadLn(InName); 29 | End; 30 | InFile.Init(InName, BufferSize + BufferPad); 31 | If Not InFile.CompOpen Then Begin 32 | WriteLn('Unable to open input file ', InName); 33 | Halt(1); 34 | End; 35 | WriteLn('Length of original file was ', InFile.CompTotal, ' bytes'); 36 | If ParamCount > 1 Then OutName := ParamStr(2) Else Begin 37 | Write('Enter output file name: '); 38 | ReadLn(OutName); 39 | End; 40 | WriteLn('EXPFILE will expand ', InName, ' to ', OutName); 41 | Write('OK? (Y/N): '); 42 | ch := UpCase(ReadKey); 43 | WriteLn(ch, ' '); 44 | If ch <> 'Y' Then Begin 45 | WriteLn('Program terminated'); 46 | Halt(1); 47 | End; 48 | {$I-} 49 | OldMode := FileMode; 50 | FileMode := WriteMode; 51 | Assign(OutFile, OutName); 52 | ReWrite(OutFile, 1); 53 | FileMode := OldMode; 54 | If IoResult <> 0 Then Begin 55 | WriteLn('Unable to open output file ', OutName); 56 | Halt(1); 57 | End; 58 | {$I+} 59 | Write('Working'); 60 | End; 61 | 62 | Procedure WriteExpandedBuffer; 63 | Var 64 | Len : Word; 65 | Begin 66 | Len := InFile.RecLength; 67 | If Len > BufferSize Then Begin 68 | WriteLn('Record longer than buffer, expansion terminated'); 69 | WriteLn('Record: ', Len ); 70 | WriteLn('Buffer: ', BufferSize); 71 | Halt(1); 72 | End; 73 | InFile.GetRecord(OutBuffer^, BufferSize); 74 | BlockWrite(OutFile, OutBuffer^, Len); 75 | Write('.'); 76 | End; 77 | 78 | Begin 79 | Initialize; 80 | While Not InFile.Eof Do WriteExpandedBuffer; 81 | WriteLn; 82 | InFile.Done; 83 | Close(OutFile); 84 | WriteLn(InName, ' expanded to ', OutName); 85 | End. -------------------------------------------------------------------------------- /Compression/HUFFMAN/HUFFMAN.PAS: -------------------------------------------------------------------------------- 1 | {$R-,I-,S-,G+} 2 | program huffman; 3 | const sb=256; 4 | type obr=record 5 | vl:longint; 6 | len:byte 7 | end; 8 | var a:array[0..511]of longint; 9 | b:array[byte]of word; 10 | c:array[0..1,byte]of word; 11 | st:array[byte]of byte; 12 | j,obc:byte; 13 | f,g:file; 14 | obb,size:longint; 15 | brp,brm,bwp:word; 16 | bufr,bufw:array[0..sb-1]of byte; 17 | reof:boolean; 18 | o:array[byte]of obr; 19 | procedure opget(var f:file;s:string); 20 | begin 21 | assign(f,s); 22 | reset(f,1); 23 | blockread(f,bufr,sb,brm) 24 | end; 25 | procedure init; 26 | begin 27 | brp:=0; 28 | brm:=0; 29 | bwp:=0; 30 | obb:=0; 31 | obc:=0; 32 | reof:=false 33 | end; 34 | procedure putc(var f:file;b:byte); 35 | begin 36 | if bwp=sb then begin blockwrite(f,bufw,sb); bwp:=0 end; 37 | bufw[bwp]:=b; 38 | inc(bwp) 39 | end; 40 | procedure clput(var f:file); 41 | begin 42 | putc(f,obb shr 24); 43 | blockwrite(f,bufw,bwp); 44 | close(f) 45 | end; 46 | procedure out(var out:file;ch:byte); 47 | var glk:byte; 48 | begin 49 | obb:=obb or o[ch].vl shl (32-o[ch].len-obc); 50 | inc(obc,o[ch].len); 51 | while obc>=8 do begin 52 | glk:=obb shr 24; 53 | putc(out,glk); 54 | obb:=obb shl 8; 55 | dec(obc,8) 56 | end 57 | end; 58 | procedure sift(l,r:word); 59 | var i,j,x:word; 60 | begin 61 | i:=l; j:=l+l+1; x:=b[l]; 62 | if (ja[b[j+1]])then inc(j); 63 | while (j<=r)and(a[x]>=a[b[j]])do begin 64 | b[i]:=b[j]; i:=j; j:=j+j+1; 65 | if (ja[b[j+1]])then inc(j) 66 | end; 67 | b[i]:=x 68 | end; 69 | procedure obh(i:word;p:byte); 70 | begin 71 | if i<256 then begin 72 | o[i].len:=p; 73 | o[i].vl:=0; 74 | for j:=0 to p-1 do o[i].vl:=o[i].vl shl 1+st[j] 75 | end 76 | else begin 77 | st[p]:=0; 78 | obh(c[0,i-256],p+1); 79 | st[p]:=1; 80 | obh(c[1,i-256],p+1) 81 | end 82 | end; 83 | procedure build; 84 | var i,p:word; 85 | begin 86 | for i:=0 to 255 do b[i]:=i; 87 | for i:=127 downto 0 do sift(i,255); 88 | p:=0; 89 | for i:=255 downto 1 do begin 90 | c[0,p]:=b[0]; 91 | b[0]:=b[i]; 92 | sift(0,i-1); 93 | c[1,p]:=b[0]; 94 | b[0]:=p+256; 95 | a[p+256]:=a[c[0,p]]+a[c[1,p]]; 96 | sift(0,i-1); 97 | inc(p) 98 | end; 99 | obh(p+255,0) 100 | end; 101 | procedure getc(var f:file); 102 | var ch:byte; 103 | begin 104 | ch:=bufr[brp]; 105 | out(g,ch); 106 | inc(a[ch]); 107 | inc(brp); 108 | if brp=brm then begin 109 | if eof(f) then reof:=true else build; 110 | blockread(f,bufr,sb,brm); brp:=0 111 | end 112 | end; 113 | begin 114 | init; 115 | opget(f,paramstr(1)); 116 | size:=filesize(f); 117 | assign(g,'test.glk'); 118 | rewrite(g,1); 119 | blockwrite(g,size,4); 120 | for j:=0 to 255 do a[j]:=1; 121 | build; 122 | while not reof do getc(f); 123 | clput(g) 124 | end. 125 | -------------------------------------------------------------------------------- /Compression/HUFFMAN/UNHUFF.PAS: -------------------------------------------------------------------------------- 1 | {$R-,I-,S-,G+} 2 | program huffman; 3 | const sb=512; 4 | var a:array[0..511]of longint; 5 | b:array[byte]of word; 6 | c:array[0..1,byte]of word; 7 | j,co,gb:byte; 8 | f,g:file; 9 | size:longint; 10 | brp,brm,bwp,pp:word; 11 | bufr,bufw:array[0..sb-1]of byte; 12 | reof:boolean; 13 | procedure opget(var f:file;s:string); 14 | begin 15 | assign(f,s); 16 | reset(f,1); 17 | blockread(f,size,4); 18 | blockread(f,bufr,sb,brm) 19 | end; 20 | procedure init; 21 | begin 22 | brp:=0; 23 | brm:=0; 24 | bwp:=0; 25 | co:=0; 26 | gb:=0; 27 | pp:=510; 28 | reof:=false 29 | end; 30 | procedure clput(var f:file); 31 | begin 32 | blockwrite(f,bufw,bwp); 33 | close(f) 34 | end; 35 | procedure sift(l,r:word); 36 | var i,j,x:word; 37 | begin 38 | i:=l; j:=l+l+1; x:=b[l]; 39 | if (ja[b[j+1]])then inc(j); 40 | while (j<=r)and(a[x]>=a[b[j]])do begin 41 | b[i]:=b[j]; i:=j; j:=j+j+1; 42 | if (ja[b[j+1]])then inc(j) 43 | end; 44 | b[i]:=x 45 | end; 46 | procedure build; 47 | var i,p:word; 48 | begin 49 | for i:=0 to 255 do b[i]:=i; 50 | for i:=127 downto 0 do sift(i,255); 51 | p:=0; 52 | for i:=255 downto 1 do begin 53 | c[0,p]:=b[0]; 54 | b[0]:=b[i]; 55 | sift(0,i-1); 56 | c[1,p]:=b[0]; 57 | b[0]:=p+256; 58 | a[p+256]:=a[c[0,p]]+a[c[1,p]]; 59 | sift(0,i-1); 60 | inc(p) 61 | end; 62 | end; 63 | function getc(var f:file):byte; 64 | var ch:byte; 65 | begin 66 | getc:=bufr[brp]; 67 | inc(brp); 68 | if brp=brm then begin 69 | blockread(f,bufr,sb,brm); brp:=0 70 | end 71 | end; 72 | procedure putc(var f:file;b:byte); 73 | begin 74 | inc(a[b]); 75 | if bwp=sb-1 then build; 76 | if bwp=sb then begin 77 | blockwrite(f,bufw,sb); 78 | bwp:=0 79 | end; 80 | dec(size); 81 | if size=0 then reof:=true; 82 | bufw[bwp]:=b; 83 | inc(bwp) 84 | end; 85 | procedure getb(var f:file); 86 | var bb:byte; 87 | begin 88 | if co=0 then begin gb:=getc(f); co:=8 end; 89 | dec(co); 90 | bb:=gb shr co and 1; 91 | pp:=c[bb,pp-256]; 92 | if pp<256 then begin putc(g,pp); pp:=510 end 93 | end; 94 | begin 95 | init; 96 | opget(f,paramstr(1)); 97 | assign(g,'test.out'); 98 | rewrite(g,1); 99 | for j:=0 to 255 do a[j]:=1; 100 | build; 101 | while not reof do getb(f); 102 | clput(g) 103 | end. 104 | -------------------------------------------------------------------------------- /Compression/LRU/DECLARE.PAS: -------------------------------------------------------------------------------- 1 | Unit Declare; 2 | 3 | Interface 4 | 5 | CONST 6 | 7 | { program parameters } 8 | { flags } 9 | FreezeFlag: boolean = false; { false for LRU queue, true to FREEZE dictionary when full } 10 | PtrType: boolean=TRUE; { false for fixed length pointers,} 11 | { true for variable length pointers} 12 | 13 | MaxChildren = 256 ; { max number of children allowed per non-root node } 14 | MaxDict = 8192 ; { max dict size; eg 4096, 8192, 16384, 32768, 65536 } 15 | MaxIncrement = 256 ; { maximum increase in length to make a new entry } 16 | MaxMatch = 1024; { maximum allowable length for a trie string } 17 | StaticSize = 256 ; { input alphabet is 0 ... ( StaticSize - 1); } 18 | { StaticSize <= 256 } 19 | 20 | 21 | TYPE 22 | TypePointer = 0..MaxDict ; { arrays will be used to store linked structures } 23 | CharType=0..StaticSize-1; { character type (input alphabet } 24 | ChildrenRange=0..MaxChildren; 25 | 26 | const 27 | MaxPtr: TypePointer=MaxDict-2; 28 | NilPtr: TypePointer=MaxDict-1; 29 | 30 | VAR 31 | 32 | 33 | 34 | dictsize: TypePointer; { current size of dictionary } 35 | trieptr: TypePointer; { used to walk up and down trie } 36 | 37 | 38 | { previous match data structure } 39 | 40 | prevptr: TypePointer ; { used to hold pointer to previous match } 41 | prevlen: TypePointer ; { length of previous match } 42 | 43 | 44 | { current match data structure } 45 | 46 | curptr: TypePointer ; { used to hold pointer to current match } 47 | curlen: 0..MaxMatch ; { length of current match } 48 | match: ARRAY [ 1 .. MaxMatch] OF CharType; { holds current match } 49 | mstart: 1..MaxMatch; { positions mstart thru mstart+curlength-1 hold match} 50 | mindex: 0..MaxMatch ; { used to walk thru match array } 51 | mval: CharType; {used by update code to hold current element of match} 52 | 53 | 54 | { variables used for input and output } 55 | inputbyte: CharType; { holds current input byte } 56 | 57 | Implementation 58 | 59 | end. 60 |  -------------------------------------------------------------------------------- /Compression/LRU/DICTNARY.PAS: -------------------------------------------------------------------------------- 1 | Unit Dictnary; 2 | Interface 3 | 4 | Uses Declare; 5 | 6 | FUNCTION ctr( pntr: TypePointer): CharType; 7 | FUNCTION parent( pntr: TypePointer): TypePointer; 8 | FUNCTION count( pntr: TypePointer): ChildrenRange; 9 | FUNCTION child( pntr: TypePointer; c : CharType): TypePointer; 10 | PROCEDURE addleaf( parpntr,pntr : TypePointer; c : CharType) ; 11 | PROCEDURE deleteleaf( pntr: TypePointer) ; 12 | 13 | 14 | Implementation 15 | type 16 | ctrfieldType=ARRAY [TypePointer] OF CharType; { character } 17 | parfieldType=ARRAY [TypePointer] OF TypePointer ; { parent } 18 | lcfieldType=ARRAY [TypePointer] OF TypePointer ; { left child } 19 | countfieldType=ARRAY [TypePointer] OF ChildrenRange; { number of children } 20 | rsibfieldType=ARRAY [TypePointer] OF TypePointer ; { right sibling } 21 | lsibfieldType=ARRAY [TypePointer] OF TypePointer ; { left sibling } 22 | 23 | var 24 | { trie data structure for the dictionary } 25 | ctrfield: ^ctrFieldType; 26 | parfield: ^parFieldType; 27 | lcfield : ^lcfieldType; 28 | countfield: ^countfieldType; 29 | rsibfield: ^rsibfieldType; 30 | lsibfield: ^lsibfieldType; 31 | 32 | 33 | 34 | 35 | FUNCTION ctr( pntr: TypePointer):CharType; 36 | BEGIN 37 | ctr := ctrfield^[pntr] 38 | END; 39 | 40 | 41 | FUNCTION parent( pntr: TypePointer): TypePointer; 42 | BEGIN 43 | parent := parfield^[pntr] 44 | END ; 45 | 46 | 47 | FUNCTION count( pntr: TypePointer):ChildrenRange; 48 | BEGIN 49 | count := countfield^[pntr] 50 | END ; 51 | 52 | 53 | FUNCTION child( pntr: TypePointer; c : CharType): TypePointer; 54 | BEGIN 55 | IF ( pntr = nilptr) THEN 56 | child := c 57 | ELSE BEGIN 58 | pntr := lcfield^[pntr] ; 59 | WHILE ( pntr <> nilptr) AND ( c<> ctrfield^[pntr]) DO 60 | pntr := rsibfield^[pntr]; 61 | child := pntr ; 62 | END ; 63 | END { child} ; 64 | 65 | 66 | 67 | PROCEDURE addleaf( parpntr,pntr : TypePointer; c : CharType) ; 68 | BEGIN 69 | ctrfield^[pntr] := c ; 70 | countfield^[pntr] := 0 ; 71 | parfield^[pntr] := parpntr ; 72 | lcfield^[pntr] := nilptr ; 73 | lsibfield^[pntr] := nilptr ; 74 | IF ( parpntr = nilptr) THEN 75 | rsibfield^[pntr] := nilptr 76 | ELSE BEGIN 77 | rsibfield^[pntr] := lcfield^[parpntr] ; 78 | IF ( lcfield^[parpntr] <> nilptr) THEN 79 | lsibfield^[lcfield^[parpntr]] := pntr ; 80 | lcfield^[parpntr] := pntr ; 81 | inc(countfield^[ parpntr]) 82 | END ; 83 | END { addleaf} ; 84 | 85 | 86 | 87 | PROCEDURE deleteleaf( pntr: TypePointer) ; 88 | BEGIN 89 | dec(countfield^[parfield^[pntr]]); 90 | IF ( lsibfield^[pntr] <> nilptr) THEN 91 | rsibfield^[lsibfield^[pntr]] := rsibfield^[pntr] 92 | ELSE 93 | lcfield^[parfield^[pntr]] := rsibfield^[pntr] ; 94 | IF ( rsibfield^[pntr] <> nilptr) THEN 95 | lsibfield^[rsibfield^[pntr]] := lsibfield^[pntr] 96 | END { deleteleaf } ; 97 | 98 | 99 | begin 100 | new(ctrfield); 101 | new(parfield); 102 | new(lcfield); 103 | new(countfield); 104 | new(rsibfield); 105 | new(lsibfield); 106 | End. -------------------------------------------------------------------------------- /Compression/LRU/IO_BYTE.PAS: -------------------------------------------------------------------------------- 1 | Unit IO_Byte; 2 | 3 | Interface 4 | 5 | Uses Dos,Declare; 6 | 7 | Procedure OpenFiles (InF,OutF : String); 8 | FUNCTION Endinput: BOOLEAN ; 9 | FUNCTION Readbyte: Byte ; 10 | PROCEDURE Writebyte( b: INTEGER) ; 11 | 12 | Type 13 | FileType = Record 14 | IOFIle : File; 15 | CurLength, 16 | CurPos : LongInt; 17 | end; 18 | 19 | 20 | Var 21 | InFile,OutFile : FileType; 22 | 23 | 24 | Implementation 25 | 26 | 27 | Procedure OpenFiles (InF,OutF : String); 28 | begin 29 | With InFile do 30 | begin 31 | Assign(IOFile,InF); 32 | {$I-} 33 | Reset(IOFIle,1); 34 | {$I+} 35 | If IOResult <> 0 then 36 | begin 37 | Writeln('ERROR : File ',InF,' Not Found.'); 38 | Halt(1); 39 | end 40 | Else 41 | begin 42 | CurPos := -1; 43 | CurLength := FileSize(IOFile) 44 | end; 45 | end; 46 | 47 | With OutFile do 48 | begin 49 | Assign(IOFile,OutF); 50 | {$I-} 51 | ReWrite(IOFile,1); 52 | {$I+} 53 | If IOResult <> 0 then 54 | begin 55 | Writeln('ERROR # ',IOResult:3,' While Opening File ',OutF); 56 | Halt(1); 57 | end 58 | Else 59 | begin 60 | CurPos := -1; 61 | CurLength := 0; 62 | end; 63 | end; 64 | end; 65 | 66 | 67 | FUNCTION Endinput: BOOLEAN ; 68 | BEGIN 69 | With InFile do 70 | begin 71 | IF (CurPos+1 = CurLength) THEN 72 | Endinput := true 73 | ELSE 74 | Endinput := false 75 | end; 76 | END { Endinput } ; 77 | 78 | 79 | 80 | FUNCTION Readbyte: Byte ; 81 | VAR 82 | Temp : Byte; 83 | BEGIN 84 | IF (EndInput) THEN 85 | ReadByte := 0 86 | Else 87 | begin 88 | Inc(InFile.CurPos); 89 | BlockRead(InFile.IOFile,Temp,1); 90 | ReadByte := Temp; 91 | end; 92 | end; 93 | 94 | 95 | PROCEDURE Writebyte (b: INTEGER) ; 96 | BEGIN 97 | With OutFile do 98 | begin 99 | BlockWrite(IOFile,b,1); 100 | Inc(CurPos); 101 | Inc(CurLength); 102 | end; 103 | END { Writebyte } ; 104 | 105 | 106 | 107 | end. 108 |  -------------------------------------------------------------------------------- /Compression/LRU/IO_PTR.PAS: -------------------------------------------------------------------------------- 1 | Unit IO_Ptr; 2 | 3 | Interface 4 | 5 | Uses Declare,IO_Byte; 6 | 7 | FUNCTION Readptr: TypePointer ; 8 | PROCEDURE Writeptr( ptr: TypePointer) ; 9 | PROCEDURE Flushbits ; 10 | 11 | 12 | 13 | Implementation 14 | 15 | var 16 | ByteBuffer: byte; 17 | BitsLeft: integer; 18 | 19 | 20 | function BitsIn(i: TypePointer): integer; 21 | var 22 | count: integer; 23 | 24 | begin 25 | count:=0; 26 | while (2 shl count) < i do 27 | inc(count); 28 | BitsIn:=count+1; 29 | end; 30 | 31 | 32 | 33 | FUNCTION Readptr: TypePointer ; 34 | VAR 35 | ptr: integer; 36 | BitsToRead: integer; 37 | count: integer; 38 | 39 | BEGIN 40 | { compute how many bits to read } 41 | 42 | IF not PtrType THEN 43 | BitsToRead := BitsIn(MaxDict) 44 | ELSE 45 | BitsToRead := BitsIn(dictsize); 46 | 47 | ptr := 0 ; 48 | for count:=BitsToRead-1 downto 0 do begin 49 | if BitsLeft=0 then begin 50 | ByteBuffer:=ReadByte; 51 | BitsLeft:=8; 52 | end; 53 | dec(BitsLeft); 54 | ptr:= ptr+ (( (ByteBuffer shr BitsLeft) and 1) shl count); 55 | end; 56 | ReadPtr:=ptr; 57 | END { Readptr } ; 58 | 59 | 60 | 61 | PROCEDURE Writeptr( ptr: TypePointer) ; 62 | VAR 63 | BitsToWrite: integer; 64 | count: integer; 65 | 66 | BEGIN 67 | IF not PtrType THEN 68 | BitsToWrite:= BitsIn(MaxDict) 69 | ELSE 70 | BitsToWrite := BitsIn(dictsize); 71 | 72 | for count:=BitsToWrite-1 downto 0 do begin 73 | if BitsLeft=8 then begin 74 | Writebyte(ByteBuffer); 75 | ByteBuffer:=0; 76 | BitsLeft:=0; 77 | end; 78 | ByteBuffer:=ByteBuffer shl 1; 79 | ByteBuffer:=ByteBuffer+((ptr shr count) and 1); 80 | inc(BitsLeft); 81 | end; 82 | 83 | END { Writeptr } ; 84 | 85 | 86 | 87 | PROCEDURE Flushbits ; 88 | BEGIN 89 | if BitsLeft<>0 then begin 90 | ByteBuffer:=ByteBuffer shl (8-BitsLeft); 91 | WriteByte(ByteBuffer); 92 | BitsLeft:=0; 93 | end; 94 | END { Flushbits } ; 95 | 96 | 97 | begin 98 | ByteBuffer:=0; 99 | BitsLeft:=0; 100 | end. -------------------------------------------------------------------------------- /Compression/LRU/MAP.PAS: -------------------------------------------------------------------------------- 1 | Unit Map; 2 | 3 | Interface 4 | 5 | Uses Declare; 6 | 7 | { 8 | NOTE: for this implementation, internal and external pointer 9 | representations are identical. Hence, all calls to INT and EXT 10 | could be removed from the code to reduce overhead. 11 | } 12 | 13 | FUNCTION int( extpointer: INTEGER): TypePointer; 14 | FUNCTION ext( intpointer: TypePointer): INTEGER ; 15 | 16 | 17 | Implementation 18 | 19 | FUNCTION int( extpointer: INTEGER): TypePointer; 20 | BEGIN 21 | int := extpointer 22 | END ; 23 | 24 | FUNCTION ext( intpointer: TypePointer): INTEGER ; 25 | BEGIN 26 | ext := intpointer 27 | END ; 28 | 29 | end. -------------------------------------------------------------------------------- /Compression/LRU/QUEUE.PAS: -------------------------------------------------------------------------------- 1 | Unit Queue; 2 | 3 | Interface 4 | 5 | Uses Declare; 6 | 7 | type 8 | FieldIndex=StaticSize..MaxDict; 9 | 10 | var 11 | qin: FieldIndex ; { right end of LRU queue, where things enter } 12 | qout: FieldIndex ; { left end of LRU queue, where things leave } 13 | place:FieldIndex ; { used to point into LRU queue } 14 | 15 | FUNCTION Older( place: FieldIndex): FieldIndex; 16 | PROCEDURE Dequeue( trieptr: FieldIndex) ; 17 | PROCEDURE Enqueue( trieptr, place: FieldIndex) ; 18 | 19 | 20 | 21 | Implementation 22 | 23 | var 24 | { LRU queue data structure } 25 | olderfield: ARRAY [FieldIndex] OF FieldIndex ; { left pointer } 26 | newerfield: ARRAY [FieldIndex] OF FieldIndex ; { right pointer } 27 | 28 | 29 | FUNCTION Older( place: FieldIndex): FieldIndex; 30 | BEGIN 31 | Older := olderfield[ place] 32 | END ; 33 | 34 | 35 | 36 | { 37 | Remove arg1 from LRU queue; 38 | assumes queue size > 1 and place not right end 39 | } 40 | PROCEDURE Dequeue( trieptr: FieldIndex) ; 41 | BEGIN 42 | IF ( trieptr = qout) THEN { delete from left } 43 | BEGIN 44 | qout := newerfield[ trieptr] ; 45 | olderfield[ qout] := nilptr 46 | END 47 | ELSE { delete from middle } 48 | BEGIN 49 | newerfield[ olderfield[ trieptr]] := newerfield[ trieptr] ; 50 | olderfield[ newerfield[ trieptr]] := olderfield[ trieptr] 51 | END 52 | END { Dequeue }; 53 | 54 | 55 | 56 | { 57 | Put arg1 after arg2 in LRU queue; 58 | if arg2 = nilptr, insert at left end 59 | } 60 | 61 | PROCEDURE Enqueue( trieptr, place: FieldIndex) ; 62 | BEGIN 63 | IF ( qin = nilptr) THEN { empty queue} 64 | BEGIN 65 | olderfield[trieptr]:=nilptr; 66 | newerfield[trieptr]:=nilptr; 67 | qin:= trieptr ; 68 | qout:= trieptr ; 69 | END 70 | ELSE IF ( place = nilptr) THEN { insert at left} 71 | BEGIN 72 | olderfield[ trieptr] := nilptr ; 73 | newerfield[ trieptr] := qout ; 74 | olderfield[ qout] := trieptr ; 75 | qout := trieptr 76 | END 77 | ELSE IF ( place = qin) THEN { append to right} 78 | BEGIN 79 | olderfield[ trieptr] := qin ; 80 | newerfield[ trieptr] := nilptr ; 81 | newerfield[ qin] := trieptr ; 82 | qin := trieptr ; 83 | END 84 | ELSE { append within the middle} 85 | BEGIN 86 | olderfield[ trieptr] := place ; 87 | newerfield[ trieptr] := newerfield[ place] ; 88 | olderfield[ newerfield[ place]] := trieptr ; 89 | newerfield[ place] := trieptr ; 90 | END 91 | END { Enqueue } ; 92 | 93 | end. -------------------------------------------------------------------------------- /Compression/LRU/README.TXT: -------------------------------------------------------------------------------- 1 | 2 | This archive contains a revised implementation of James Storer LRU 3 | data compression method. 4 | Originally, I downloaded PASLRU.ARC, which contained the same source 5 | code, but with some bugs in it. I did 3 things to the source code: 6 | 7 | 1. Removed the bugs 8 | 2. Altered some type definitions so that dictionnary sizes of >4096 9 | could be tolerated 10 | 3. Moved some definitions in other places, and rewrote some things so that 11 | the code compiles even when run time checking is on 12 | 13 | You can compile the source code with turbo pascal. I found the LRU 14 | algorithm not superior to LHARC 1.13c, but slightly faster. 15 | This is not industrial strength code, but the bugs have been eliminated. 16 | 17 | 18 | I can be reached by the original uploader. (Johnny Penet) 19 | 20 | 21 | Enjoy. 22 | 23 | Vincent Van Den Berghe 24 | Jordaenstraat 3 25 | 8510 Kortrijk-Marke 26 | BELGIUM 27 |  -------------------------------------------------------------------------------- /Compression/LZH/LZH.TXT: -------------------------------------------------------------------------------- 1 | The LZH unit implements a fairly faithful port of an algorithm that was 2 | written in C by Haruyasu Yoshizaki and Haruhiko Okumura. 3 | 4 | The Documentation on how to use the unit is pretty goodm the source code 5 | is pretty much undocumented. 6 | 7 | Included is a simple 1 file compression program as a demonstration 8 | on how to use the LZH unit. 9 | 10 | 11 | Douglas P. Webb 12 | dwebb@binkley.cs.mcgill.ca 13 | 14 | -------------------------------------------------------------------------------- /Compression/LZSS/LZSS.TXT: -------------------------------------------------------------------------------- 1 | The LZSS program implements a turbo pascal wrapper I've placed around a 2 | very nice (and fast) implementation of the LZ77 algorithm submitted to the 3 | DR DOBBS compression contest a few years back by Andy Tam. 4 | 5 | The algorithm is implemented in the context of a stand-alone file 6 | compression utility, which can be used to compress/decompress files 7 | one at a time. 8 | 9 | It should be noted that the plain LZ77 algorithm is unpatented, so using 10 | this code in a commercial application should be OK. 11 | 12 | Douglas P. Webb 13 | dwebb@binkley.cs.mcgill.ca 14 | 15 | -------------------------------------------------------------------------------- /Compression/LZW2/readme.txt: -------------------------------------------------------------------------------- 1 | LZW 12-bit Coder/DeCoder with variable code length. -------------------------------------------------------------------------------- /Compression/SIXPACK/SIXPACK.TXT: -------------------------------------------------------------------------------- 1 | The SIXPACK program implements a faithful port from C of a unique 2 | compression algorithm submitted to the DR DOBBS compression contest 3 | a few years back by Philip G. Gage. 4 | 5 | The algorithm is implemented in the context of a stand-alone file 6 | compression utility, which can be used to compress/decompress files 7 | one at a time. 8 | 9 | 10 | 11 | NOTE: There is a statement in sixpack: 12 | 13 | CONST 14 | MaxDistance : Integer = CopyMax[PRED(COPYRANGES)]; 15 | 16 | which causes the TP7 compiler to give the error "cannot evaluate 17 | this expression". I have no idea why, but so long as you don't 18 | change anything else, you can hard code the value to be: 19 | 20 | CONST 21 | MaxDistance : integer = 21839; 22 | 23 | TP6 does not have this problem. 24 | 25 | 26 | Douglas P. Webb 27 | dwebb@binkley.cs.mcgill.ca 28 | 29 | -------------------------------------------------------------------------------- /Data Structures/Arrays/BUBBLE.PAS: -------------------------------------------------------------------------------- 1 | { Сортировка слов в предложении методом пузырьковой сортировки } 2 | program bubblesort; 3 | 4 | function prevspace(s:string;from:integer):integer; 5 | begin 6 | repeat 7 | dec(from); 8 | until (copy(s,from,1)=' ') or (from=1); 9 | while (copy(s,from-1,1)=' ') and (from>1) do 10 | dec(from); 11 | if (from=1) then 12 | dec(from); 13 | prevspace:=from; 14 | end; 15 | 16 | function nextspace(s:string;from:integer):integer; 17 | begin 18 | repeat 19 | inc(from); 20 | until (copy(s,from,1)=' ') or (from=length(s)); 21 | while(copy(s,from+1,1)=' ') and (froms2; 31 | end; 32 | 33 | procedure bsort(var s:string); 34 | var i,j,nw,nnw:integer; 35 | forswap:string; 36 | begin 37 | i:=length(s)+1; 38 | while (i>nextspace(s,1)) do (* Пока i не дойдёт с последнего слова до первого *) 39 | begin 40 | j:=0; 41 | while (jdivider) do 57 | dec(j); 58 | 59 | if (i=j); 63 | 64 | arr[ifrom]:=arr[j]; 65 | arr[j]:=divider; 66 | 67 | quicksort(arr,ifrom,j-1); 68 | quicksort(arr,j+1,ito); 69 | end; 70 | 71 | end; 72 | 73 | var arr:TArr; 74 | ArrSize:Integer; 75 | 76 | begin 77 | clrscr; 78 | writeln('Быстрая сортировка массива.'); 79 | GetArray(Arr,ArrSize); 80 | clrscr; 81 | writeln('Исходный массив : '); 82 | PrintArray(Arr,Arrsize); 83 | quicksort(Arr,1,Arrsize); 84 | writeln('Отсортированный массив : '); 85 | PrintArray(Arr,Arrsize); 86 | writeln('Нажмите любую клавишу для выхода.'); 87 | readkey; 88 | end. 89 | -------------------------------------------------------------------------------- /Data Structures/Arrays/sortmerg.pas: -------------------------------------------------------------------------------- 1 | { 2 | Слияние двух отсортированных массивов. 3 | В результате образуется один отсортированный массив. 4 | 5 | Для Borland Pascal 7.0 6 | Olegis, 01.2005 7 | } 8 | 9 | var 10 | bufin1, bufin2, bufout: text; 11 | i: integer; 12 | in1,in2: integer; 13 | 14 | begin 15 | assign(bufin1, 'inp1.txt'); reset(bufin1); 16 | assign(bufin2, 'inp2.txt'); reset(bufin2); 17 | assign(bufout, 'output.txt'); rewrite(bufout); 18 | 19 | readln(bufin1, in1); 20 | readln(bufin2, in2); 21 | 22 | while (not eof(bufin1)) and (not eof(bufin2)) do 23 | begin 24 | if in1<=in2 then 25 | begin 26 | writeln(bufout, in1); 27 | readln(bufin1, in1); 28 | end 29 | else 30 | begin 31 | writeln(bufout, in2); 32 | readln(bufin2, in2); 33 | end; 34 | end; 35 | 36 | if eof(bufin1) then 37 | begin 38 | close(bufin1); 39 | while not eof(bufin2) do 40 | begin 41 | readln(bufin2, in2); 42 | writeln(bufout, in2); 43 | end; 44 | close(bufin2); 45 | end; 46 | 47 | if eof(bufin2) then 48 | begin 49 | close(bufin2); 50 | while not eof(bufin1) do 51 | begin 52 | readln(bufin1, in1); 53 | writeln(bufout, in1); 54 | end; 55 | close(bufin1); 56 | end; 57 | close(bufout); 58 | end. -------------------------------------------------------------------------------- /Data Structures/Lists/fifo_dyn.pas: -------------------------------------------------------------------------------- 1 | program fifo_dyn; 2 | uses CRT; 3 | 4 | type pt = ^elem; 5 | elem = record 6 | info : byte; 7 | next,prev : pt; 8 | end; 9 | 10 | function getelem:byte; 11 | var s:byte; 12 | begin 13 | write('Введите число : '); 14 | readln(s); 15 | getelem:=s; 16 | end; 17 | 18 | procedure push(var root,tail:pt;info:byte); 19 | var newelem:pt; 20 | begin 21 | new(newelem); (* Создать в памяти новый элемент *) 22 | newelem^.info:=info; 23 | newelem^.next:=root; (* Присоединить очередь к этому элементу *) 24 | newelem^.prev:=NIL; 25 | if (root<>NIL) then (* Если очередь не пуста *) 26 | root^.prev:=newelem (* Присоединить этот элемент к началу очереди *) 27 | else (* Иначе *) 28 | tail:=newelem; (* Создать новую очередь *) 29 | root:=newelem; 30 | end; 31 | 32 | procedure pop(var root,tail:pt); 33 | var temp:pt; 34 | begin 35 | if (tail<>NIL) then (* Если очередь не пуста *) 36 | begin 37 | temp:=tail; (* Сохранить адрес последнего элемента *) 38 | tail:=tail^.prev; (* Отрезать последний элемент от очереди *) 39 | if (tail=NIL) then 40 | root:=NIL 41 | else 42 | tail^.next:=NIL; 43 | writeln('Извлечённое значение : ',temp^.info); (* Вывести на экран значение последнего элемента *) 44 | dispose(temp); (* Убрать последний элемент из памяти *) 45 | end 46 | else (* Иначе, если очередь пуста *) 47 | Writeln('Очередь пуста'); 48 | end; 49 | 50 | procedure showmenu; 51 | begin 52 | Writeln (' 1) Push '); 53 | Writeln (' 2) Pop '); 54 | Writeln (' 3) Выход '); 55 | Write(' -> '); 56 | end; 57 | 58 | var root,tail: pt; 59 | selection : byte; 60 | 61 | begin 62 | Writeln (' FIFO. Динамическая реализация '); 63 | root:=NIL; 64 | repeat 65 | showmenu; 66 | readln(selection); 67 | case selection of 68 | 1: push(root,tail,getelem); 69 | 2: pop(root,tail); 70 | 3: clrscr; 71 | end; 72 | until selection=3; 73 | end. 74 | -------------------------------------------------------------------------------- /Data Structures/Lists/fifo_st.pas: -------------------------------------------------------------------------------- 1 | program fifo_st; 2 | uses CRT; 3 | 4 | const FIFOsize=10; 5 | 6 | type TFIFO = array[1..FIFOsize] of byte; 7 | 8 | function getelem:byte; 9 | var s:byte; 10 | begin 11 | write('Введите число : '); 12 | readln(s); 13 | getelem:=s; 14 | end; 15 | 16 | procedure push (var FIFO:TFifo;var root,tail:integer;info:byte); 17 | begin 18 | if ((tail=root) and (root<>0)) then (* Если очередь переполнена *) 19 | writeln('Очередь переполнена') (* Сообщить об этом *) 20 | else (* Иначе *) 21 | begin 22 | if (root=0) then (* Если очередь пуста *) 23 | begin 24 | root:=1; (* Создать новую очередь *) 25 | tail:=1; 26 | end; 27 | fifo[tail]:=info; (* Занести элемент в очередь *) 28 | inc(tail); (* Передвинуть указатель хвоста очереди на 1 вправо *) 29 | if (tail>FIFOSize) then (* Если указатель вышел за конец массива *) 30 | tail:=1; (* Перенести его в начало массива *) 31 | end; 32 | end; 33 | 34 | procedure pop(var FIFO:TFifo;var root,tail:integer); 35 | begin 36 | if (tail=0) then (* Если очередь пуста *) 37 | writeln('Очередь пуста') (* Сообщить об этом *) 38 | else (* Иначе *) 39 | begin 40 | writeln('Извлечённое число : ',FIFO[root]); (* Извлечь число из очереди *) 41 | inc(root); (* Сдвинуть указатель корня очереди на 1 вправо *) 42 | if (root>FIFOSize) then (* Если корень вышел за пределы массива *) 43 | root:=1; (* Вернуть его в начало *) 44 | if (root=tail) then (* Если из очереди извлечён последний элемент *) 45 | begin 46 | root:=0; (* Создать пустую очередь *) 47 | tail:=0; 48 | end; 49 | end; 50 | end; 51 | 52 | procedure showmenu; 53 | begin 54 | Writeln(' 1) Push'); 55 | Writeln(' 2) Pop'); 56 | Writeln(' 3) Выход'); 57 | Write(' -> '); 58 | end; 59 | 60 | var root,tail:integer; 61 | FIFO:TFIFO; 62 | selection:integer; 63 | 64 | begin 65 | root:=0; 66 | tail:=0; 67 | Writeln('Очередь. Статическая реализация.'); 68 | repeat 69 | showmenu; (* Показать меню *) 70 | readln(selection); (* Ввести с клавиатуры пункт меню *) 71 | case selection of (* Выполнить действие, затребованное пользователем *) 72 | 1: push(FIFO,root,tail,getelem); 73 | 2: pop(FIFO,root,tail); 74 | 3: clrscr; 75 | end; 76 | until selection=3; (* Если пользователь выбрал не выход, повторить *) 77 | end. 78 | -------------------------------------------------------------------------------- /Data Structures/Lists/hash_lin.pas: -------------------------------------------------------------------------------- 1 | program hash_lin; 2 | 3 | Const MaxWordLength = 10; 4 | 5 | Type TWord = string[MaxWordLength]; 6 | 7 | Const HashSize = 997; 8 | 9 | Const EmptyElem:TWord=''; 10 | 11 | Type THash = file of TWord; 12 | 13 | Function InitHash(var Hash:THash):boolean; 14 | var i:integer; 15 | begin 16 | assign(Hash,'hash.tmp'); 17 | {$I-} 18 | rewrite(hash); 19 | {$I+} 20 | if IOResult<>0 then 21 | begin 22 | InitHash:=false; 23 | end 24 | else 25 | begin 26 | InitHash:=true; 27 | for i:=0 to HashSize-1 do 28 | write(hash,EmptyElem); 29 | end; 30 | end; 31 | 32 | Procedure DeInitHash(var Hash:THash); 33 | begin 34 | close(Hash); 35 | end; 36 | 37 | function getelem(elname:string):TWord; 38 | var s:TWord; 39 | begin 40 | write('Введите ',elname,' : '); 41 | readln(s); 42 | getelem:=s; 43 | end; 44 | 45 | Function FHash(s:TWord):integer; 46 | var i:integer; 47 | t,mul:longint; 48 | begin 49 | t:=0; 50 | mul:=1; 51 | for i:=length(s) downto 1 do 52 | begin 53 | t:=t + (ord(s[i])*mul); 54 | mul:=mul*5; 55 | end; 56 | FHash:=t mod HashSize; 57 | end; 58 | 59 | procedure add2hash (var hash:THash;elem:TWord); 60 | var posit:integer; 61 | temp:TWord; 62 | begin 63 | posit:=fhash(elem); 64 | seek(hash,posit); 65 | repeat 66 | inc(posit); 67 | if (posit>hashSize) then 68 | begin 69 | seek(Hash,0); 70 | posit:=1; 71 | end; 72 | read(Hash,temp); 73 | until (temp=EmptyElem); 74 | seek(hash,posit-1); 75 | write(hash,elem); 76 | end; 77 | 78 | procedure searchhashelem (var hash:THash;elem:TWord); 79 | var f:integer; 80 | temp:TWord; 81 | begin 82 | writeln; 83 | f:=fhash(elem); 84 | seek(hash,f); 85 | repeat 86 | if eof(hash) then 87 | seek(Hash,0); 88 | read(hash,temp) 89 | until (temp=EmptyElem) or (temp=elem); 90 | if (temp=elem) then 91 | writeln('Элемент существует в хеше.') 92 | else 93 | writeln('Элемент не существует в хеше.'); 94 | end; 95 | 96 | Procedure Showmenu; 97 | begin 98 | Writeln; 99 | Writeln('Хеш с линейным разрешением коллизий'); 100 | Writeln('1) Добавить элемент в хеш'); 101 | Writeln('2) Поиск элемента в хеше'); 102 | Writeln('3) Выход'); 103 | Writeln; 104 | Write(' Ваш выбор : '); 105 | end; 106 | 107 | Var Hash:THash; 108 | selection:integer; 109 | 110 | begin 111 | Writeln('Инициализация хеша...'); 112 | if (not (InitHash(Hash))) then 113 | writeln('Не могу инициализировать хеш!') 114 | else 115 | begin 116 | repeat 117 | showmenu; 118 | readln(selection); 119 | writeln; 120 | case selection of 121 | 1: add2hash(Hash,getelem('слово для добавления')); 122 | 2: searchhashelem(Hash,getelem('слово для поиска')); 123 | end; 124 | until selection=3; 125 | DeInitHash(Hash); 126 | end; 127 | end. 128 | -------------------------------------------------------------------------------- /Data Structures/Lists/linkprocs.pas: -------------------------------------------------------------------------------- 1 | Type 2 | Link = ^Node; 3 | Node = record 4 | Data: integer; 5 | Next: Link; 6 | End; 7 | 8 | Var 9 | Head, z: link; 10 | 11 | procedure list_initialize; 12 | begin 13 | new( head ); 14 | new( z ); 15 | head^.next := z; 16 | z^.next := nil; 17 | end; 18 | 19 | procedure insert_after( v : integer; t : link ); 20 | var 21 | x : link; 22 | begin 23 | new(x); 24 | x^.data := v; 25 | x^.next := t^.next; 26 | t^.next := x; 27 | end; 28 | 29 | procedure delete_next( t : link ); 30 | var 31 | del: link; 32 | begin 33 | del := t^.next; 34 | t^.next := t^.next^.next; 35 | dispose(del); 36 | end; 37 | -------------------------------------------------------------------------------- /Data Structures/Lists/queue_sort.PAS: -------------------------------------------------------------------------------- 1 | 2 | Type 3 | ttype = integer; 4 | 5 | ptitem = ^titem; 6 | titem = Record 7 | data: ttype; 8 | next: ptitem; 9 | End; 10 | 11 | tqueue = Object 12 | head, tail: ptitem; 13 | 14 | constructor init; 15 | destructor done; 16 | 17 | Procedure put(x: ttype); 18 | 19 | Function get: ttype; 20 | 21 | Function empty: boolean; 22 | 23 | Procedure print; 24 | 25 | Function get_count: word; 26 | End; 27 | 28 | 29 | constructor tqueue.init; 30 | Begin 31 | head := Nil; 32 | tail := Nil; 33 | End; 34 | destructor tqueue.done; 35 | Begin 36 | while empty Do get 37 | End; 38 | 39 | Procedure tqueue.put(x: ttype); 40 | 41 | Var p: ptitem; 42 | Begin 43 | new(p); 44 | p^.data := x; 45 | p^.next := Nil; 46 | If empty Then head := p 47 | Else tail^.next := p; 48 | tail := p 49 | End; 50 | 51 | Function tqueue.get: ttype; 52 | 53 | Var p: ptitem; 54 | Begin 55 | If Not empty Then 56 | Begin 57 | p := head; 58 | head := head^.next; 59 | 60 | get := p^.data; 61 | dispose(p); 62 | End 63 | Else 64 | Begin 65 | writeln('reading from empty queue'); 66 | halt(102) 67 | End; 68 | End; 69 | 70 | Function tqueue.empty: boolean; 71 | Begin 72 | empty := Not assigned(head) 73 | End; 74 | 75 | Procedure tqueue.print; 76 | 77 | Var p: ptitem; 78 | Begin 79 | p := head; 80 | write('(queue) <'); 81 | while assigned(p) Do 82 | Begin 83 | write(p^.data, ' '); 84 | p := p^.next 85 | End; 86 | writeln('>') 87 | End; 88 | 89 | Function tqueue.get_count: word; 90 | 91 | Var 92 | count: word; 93 | p: ptitem; 94 | Begin 95 | p := head; 96 | count := 0; 97 | while assigned(p) Do 98 | Begin 99 | inc(count); 100 | p := p^.next 101 | End; 102 | get_count := count 103 | End; 104 | 105 | { А вот и сама сортировка очереди } 106 | 107 | Procedure sort(Var q: tqueue); 108 | 109 | Var 110 | i, j, k, 111 | it, it_next: integer; 112 | len: word; 113 | Begin 114 | len := q.get_count; 115 | For i := 1 To len Do 116 | Begin 117 | it := q.get; 118 | For j := 1 To len - i Do 119 | Begin 120 | it_next := q.get; 121 | If it > it_next Then 122 | Begin 123 | q.put(it); 124 | it := it_next; 125 | End 126 | Else 127 | q.put(it_next) 128 | End; 129 | 130 | For k := 1 To pred(i) Do 131 | q.put(q.get); 132 | 133 | q.put(it); 134 | End; 135 | End; 136 | 137 | Const 138 | test: array[1 .. 10] Of integer = 139 | (2, 5, 17, 7, 9, 3, 4, 6, 11, 71); 140 | 141 | Var 142 | i: integer; 143 | qint: tqueue; 144 | 145 | Begin 146 | qint.init; 147 | 148 | For i := 1 To 10 Do 149 | qint.put(test[i]); 150 | qint.print; 151 | sort(qint); 152 | qint.print; 153 | 154 | qint.done; 155 | End. 156 | -------------------------------------------------------------------------------- /Data Structures/Lists/sort_stack.pas: -------------------------------------------------------------------------------- 1 | 2 | { Volvo (c) } 3 | 4 | Const maxStack = 100; 5 | Type 6 | TType = Integer; 7 | TStack = Record 8 | stArr: Array[1 .. maxStack] Of TType; 9 | currTop: Integer; 10 | End; 11 | 12 | Procedure Init(Var s: TStack); 13 | Begin 14 | s.currTop := 0 15 | End; 16 | 17 | Procedure Push(Var s: TStack; x: TType); 18 | Begin 19 | If s.currTop <> maxStack Then 20 | Begin 21 | Inc(s.currTop); s.stArr[s.currTop] := x; 22 | End; 23 | End; 24 | 25 | Function Pop(Var s: TStack): TType; 26 | Begin 27 | If s.currTop <> 0 Then 28 | Begin 29 | Pop := s.stArr[s.currTop]; Dec(s.currTop); 30 | End; 31 | End; 32 | 33 | Function Top(Var s: TStack): TType; 34 | Begin 35 | Top := s.stArr[s.currTop]; 36 | End; 37 | 38 | Function IsEmpty(Var s: TStack): Boolean; 39 | Begin 40 | IsEmpty := (s.currTop = 0) 41 | End; 42 | 43 | Procedure Print(Var s: TStack); 44 | Var i: Integer; 45 | Begin 46 | For i := 1 To s.currTop Do 47 | Write(s.stArr[i]:4); 48 | WriteLn 49 | End; 50 | 51 | 52 | Const 53 | n = 10; 54 | arr: Array[1 .. n] Of TType = 55 | (1, 2, 4, 5, 2, 6, 7, 0, 9, 2); 56 | 57 | Var 58 | mainStack, resStack, tmpStack: TStack; 59 | i: integer; 60 | 61 | begin 62 | Init(mainStack); 63 | Init(resStack); 64 | Init(tmpStack); 65 | 66 | For i := 1 To n Do 67 | Push(mainStack, arr[i]); 68 | Print(mainStack); 69 | 70 | While not IsEmpty(mainStack) Do 71 | Begin 72 | If IsEmpty(resStack) or (Top(resStack) < Top(mainStack)) 73 | Then Push(resStack, Pop(mainStack)) 74 | Else 75 | Begin 76 | While (Top(resStack) > Top(mainStack)) and 77 | (not IsEmpty(resStack)) Do 78 | Push(tmpStack, Pop(resStack)); 79 | Push(resStack, Pop(mainStack)); 80 | While not IsEmpty(tmpStack) Do 81 | Push(resStack, Pop(tmpStack)) 82 | End 83 | End; 84 | Print(resStack) 85 | end. -------------------------------------------------------------------------------- /Data Structures/Lists/sortlinkedlist.pas: -------------------------------------------------------------------------------- 1 | type 2 | PList = ^TList; 3 | TList = record 4 | a: integer; 5 | next : PList; 6 | end; 7 | 8 | // сортировка односвязного списка 9 | procedure sortList(head:PList); 10 | var p1, p2, pm, lpm, lp, p : PList; 11 | begin 12 | p1 := head.next; 13 | p2 := head; 14 | while p1 <> nil do begin 15 | // Поиск минимального элемента 16 | pm := p1; lpm := nil; p := p1; lp := nil; 17 | while p <> nil do begin 18 | if p.a <= pm.a then begin 19 | pm := p; 20 | lpm := lp; // Запоминаем предыдущий 21 | end; 22 | lp := p; 23 | p := p.next; 24 | end; 25 | // Минимальный элемент убираем из списка 26 | if lpm = nil 27 | then p1 := pm.next 28 | else lpm.next := pm.next; 29 | // и помещаем в новый список 30 | p2.next := pm; 31 | p2 := p2.next; 32 | p2.next := nil; 33 | end; 34 | end; 35 | 36 | procedure PrintList (var head: PList); 37 | var p:PList; 38 | begin 39 | p:=head^.next; 40 | while p<>nil do begin 41 | write(p^.a:6); 42 | p:=p^.next; 43 | end; 44 | writeln; 45 | end; -------------------------------------------------------------------------------- /Data Structures/Trees/redblack.pas: -------------------------------------------------------------------------------- 1 | { сильноветвящиеся деревья } 2 | { Красно - черные деревья } 3 | 4 | Program PoiskByTree; 5 | 6 | Type 7 | rec = Record 8 | fio: string [40]; 9 | gr: string[4]; 10 | kurs: string[1]; 11 | End; 12 | 13 | link = ^l; 14 | l = Record 15 | key: rec; 16 | red: boolean; 17 | l,r: link; 18 | End; 19 | 20 | Var 21 | head, w: link; 22 | k: rec; 23 | st1: string; 24 | f: file Of rec; 25 | 26 | Function rotate(v:rec;y:link): link; 27 | 28 | Var 29 | c,gs: link; 30 | Begin 31 | If v.fio[1] (v.fio[1] < p^.key.fio[1]) Then 59 | p := rotate(v,g); 60 | m := rotate(v,gg); 61 | m^.red := false; 62 | End; 63 | head^.r^.red := false; 64 | split := m; 65 | End; 66 | 67 | Function insert(v : rec; n : link): link; 68 | 69 | Var 70 | q1,q2,p : link; 71 | Begin 72 | p := n; 73 | q1 := p; 74 | Repeat 75 | q2 := q1; 76 | q1 := p; 77 | p := n; 78 | If v.fio[1]x^.key.fio Do 95 | If st...'); 31 | ReadLn; 32 | CloseGraph; 33 | end. 34 | -------------------------------------------------------------------------------- /Graphics/Color/HSI/HSI.DOC: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Graphics/Color/HSI/HSI.DOC -------------------------------------------------------------------------------- /Graphics/Color/HSI/HSI.PAS: -------------------------------------------------------------------------------- 1 | program HSI; { by Bret Mulvey } 2 | 3 | { illustrates conversion of Hue-Saturation-Intensity to Red-Green-Blue } 4 | 5 | uses 6 | Crt,VGA256; 7 | 8 | procedure hsi2rgb(h,s,i: real; var C: ColorValue); 9 | var 10 | t: real; 11 | rv,gv,bv: real; 12 | begin { procedure hsi2rgb } 13 | t:=2*pi*h; 14 | rv:=1+s*sin(t-2*pi/3); 15 | gv:=1+s*sin(t); 16 | bv:=1+s*sin(t+2*pi/3); 17 | t:=63.999*i/2; 18 | C.Rvalue:=trunc(rv*t); 19 | C.Gvalue:=trunc(gv*t); 20 | C.Bvalue:=trunc(bv*t); 21 | end; { procedure hsi2rgb } 22 | 23 | var 24 | h,s,i: real; 25 | x,y,z: integer; 26 | C: ColorValue; 27 | p: vgaPaletteType; 28 | ch: char; 29 | xx,yy: integer; 30 | ii,jj: integer; 31 | K: integer; 32 | t: Real; 33 | 34 | begin 35 | 36 | { create grey scale } 37 | for z:=0 to 15 do with p[z] do begin Rvalue:=z*4; Gvalue:=z*4; Bvalue:=z*4; end; 38 | 39 | { create HSI spectrum } 40 | for x:=0 to 3 do { four different intensities } 41 | for y:=0 to 2 do { three different saturations } 42 | for z:=0 to 19 do { twenty different hues } 43 | begin 44 | { determine H,S,I between 0 and 1 } 45 | h:=z/20; 46 | s:=(y+1)/3; 47 | i:=(x+1)/4; 48 | { calculate and store R,G,B values } 49 | hsi2rgb(h,s,i,C); 50 | p[16+z+20*y+60*x]:=C; 51 | end; 52 | 53 | InitVGA256; 54 | vgaSetAllPalette(p); 55 | 56 | { draw grey scale } 57 | for x:=0 to 15 do 58 | begin 59 | xx:=200; yy:=x*8; 60 | for ii:=0 to 7 do 61 | for jj:=0 to 7 do 62 | vgaPutPixel(xx+ii,yy+jj,15-x); 63 | end; 64 | 65 | { draw spectrum } 66 | for z:=0 to 19 do 67 | for x:=0 to 3 do 68 | for y:=0 to 2 do 69 | begin 70 | K:=16+z+20*y+60*x; 71 | xx:=8*x+40*(z mod 5); 72 | yy:=8*y+32*(z div 5); 73 | for ii:=0 to 7 do 74 | for jj:=0 to 7 do 75 | vgaPutPixel(xx+ii,yy+jj,K); 76 | end; 77 | 78 | ch:=ReadKey; if ch=#0 then ch:=ReadKey; 79 | CloseVGA256; 80 | end. -------------------------------------------------------------------------------- /Graphics/Color/HSI/VGA256.PAS: -------------------------------------------------------------------------------- 1 | unit vga256; 2 | 3 | interface 4 | 5 | uses 6 | Crt,Dos; 7 | 8 | type 9 | ColorValue = record Rvalue,Gvalue,Bvalue: byte; end; 10 | vgaPaletteType = array [0..255] of ColorValue; 11 | 12 | procedure InitVGA256; 13 | procedure CloseVGA256; 14 | procedure vgaPutPixel(x,y: integer; c: byte); 15 | function vgaGetPixel(x,y: integer): byte; 16 | procedure vgaSetAllPalette(var p: vgaPaletteType); 17 | 18 | implementation 19 | 20 | procedure InitVGA256; 21 | begin { procedure InitVGA256 } 22 | Inline($B8/$13/0/$CD/$10); 23 | end; { procedure InitVGA256 } 24 | 25 | procedure CloseVGA256; 26 | begin { procedure CloseVGA256 } 27 | TextMode(LastMode); 28 | end; { procedure CloseVGA256 } 29 | 30 | procedure vgaPutPixel(x,y: integer; c: byte); 31 | begin { procedure vgaPutPixel } 32 | Mem[$A000:word(320*y+x)]:=c; 33 | end; { procedure vgaPutPixel } 34 | 35 | function vgaGetPixel(x,y: integer): byte; 36 | begin { function vgaGetPixel } 37 | vgaGetPixel:=Mem[$A000:word(320*y+x)]; 38 | end; { function vgaGetPixel } 39 | 40 | procedure vgaSetAllPalette(var p: vgaPaletteType); 41 | var regs: Registers; 42 | begin { procedure vgaSetAllPalette } 43 | with regs do 44 | begin 45 | AX:=$1012; 46 | BX:=0; 47 | CX:=256; 48 | ES:=Seg(p); 49 | DX:=Ofs(p); 50 | end; 51 | Intr($10,regs); 52 | end; { procedure vgaSetAllPalette } 53 | 54 | end. -------------------------------------------------------------------------------- /Graphics/Color/RGB2HLS/RGB2HLS.MSG: -------------------------------------------------------------------------------- 1 | Д 4INT ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД It's interesting Д 2 | Msg : 36 of 202 Addr Date 3 | From : Dmitry Karasik 2:464/46.36 25.04.97 4 | Subj : ЏаҐ®Ўа §®ў ­ЁҐ RGB <-> HLS 5 | ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД 6 | Гґeііo Kolya! 7 | і` `` 8 | ` 9 | —Ґв ЂЇp 17 1997 18:56, Kolya Nesterov wrote to All: 10 | 11 | KN> ­г¦Ґ­ ЇpЁ­жлЇ ЇҐpҐЄ®¤Ёp®ўЄЁ Ё§ RGB (­ ¤Ґобм §­ ов ўбҐ) 12 | KN> ў HLS (Hue-Luminance-Saturation)) 13 | 14 | „Ґа¦Ё: 15 | ‘ ­ Ё«гзиЁ¬Ё, Dmitry 16 | 17 | --- ЃҐиҐ­л© Њ ­мпЄ 2.50+ 18 | * Origin: Remember - Crazy Chickatilo's watching you! (2:464/46.36) 19 | 20 | -------------------------------------------------------------------------------- /Graphics/Color/RGB2HLS/RGB2HLS.PAS: -------------------------------------------------------------------------------- 1 | { From : Dmitry Karasik 2:464/46.36 25.04.97 2 | Subj : Преобразование RGB <-> HLS 3 | --------------------------------------------------} 4 | {Hue, Luminocity, Saturation} 5 | Procedure RGBToHLS(R, G, B : Word; var H, L, S : integer); 6 | Var 7 | cr,cg,cb,m1,m2,ir,ig,ib,ih,il,is:real; 8 | Begin 9 | m1 := MaxWord(MaxWord(r, g), b) / 63; 10 | m2 := MinWord(MinWord(r, g), b) / 63; 11 | ir := r / 63; 12 | ig := g / 63; 13 | ib := b / 63; 14 | il := (m1 + m2) / 2; 15 | if m1 = m2 then begin 16 | is := 0; 17 | ih := 0; 18 | end else begin 19 | if il <= 0.5 then is := (m1 - m2) / (m1 + m2) else 20 | is := (m1 - m2) / (2 - m1 - m2); 21 | cr := (m1 - ir) / (m1 - m2); 22 | cg := (m1 - ig) / (m1 - m2); 23 | cb := (m1 - ib) / (m1 - m2); 24 | if ir = m1 then ih := cb - cg; 25 | if ig = m1 then ih := 2 + cr - cb; 26 | if ib = m1 then ih := 4 + cg - cr; 27 | end; 28 | h := Round(60 * ih); 29 | if h < 0 then h := h + 360; 30 | l := Round(il * 100); 31 | s := Round(is * 100); 32 | End; 33 | 34 | Procedure HLSToRGB(H, L, S : Word; var R, G, B : Integer); 35 | 36 | Function XRGB(HH, mm1, mm2 : Real) : Real; 37 | Begin 38 | if hh < 0 then hh := hh + 360; 39 | if hh > 360 then hh := hh - 360; 40 | if hh < 60 then xrgb := mm1 + (mm2 - mm1) * hh / 60 else 41 | if hh < 180 then xrgb := mm2 else 42 | if hh < 240 then xrgb := mm1 + (mm2 - mm1) * (240 - hh) / 60 else 43 | xrgb := mm1; 44 | End; 45 | 46 | Var 47 | cr,cg,cb,m1,m2,ir,ig,ib,ih,il,is : Real; 48 | Begin 49 | il := l / 100; 50 | ih := h; 51 | is := s / 100; 52 | if il <= 0.5 then m2 := il * (1 + is) else m2 := il + is - il * is; 53 | m1 :=2 * il - m2; 54 | if s = 0 then begin 55 | ir := il; 56 | ig := il; 57 | ib := il 58 | end else begin 59 | ir := XRGB(ih + 120, m1, m2); 60 | ig := XRGB(ih , m1, m2); 61 | ib := XRGB(ih - 120, m1, m2); 62 | end; 63 | r := Round(ir * 63); 64 | g := Round(ig * 63); 65 | b := Round(ib * 63); 66 | End; 67 | 68 | 69 | 70 | Procedure GetDeviceExtension(Device : Pointer; var Ext : TRect); 71 | Begin 72 | Ext.A.X := 0; 73 | Ext.A.Y := 0; 74 | if Device = Nil then begin 75 | Ext.B.X := ScreenDriver^.MaximalX; 76 | Ext.B.Y := ScreenDriver^.MaximalY; 77 | end else begin 78 | Ext.B.X := PSImage(Device)^.X - 1; 79 | Ext.B.Y := PSImage(Device)^.Y - 1; 80 | end; 81 | End; 82 | 83 | Function IsImageStreamed(Image : PImage) : Boolean; 84 | Begin 85 | IsImageStreamed := (PSImage(Image)^.NBP and imFlatStream) <> 0; 86 | End; 87 | 88 | -------------------------------------------------------------------------------- /Graphics/JULIASET.PAS: -------------------------------------------------------------------------------- 1 | { 2 | To try out the program, some complex constants you can 3 | use are -1, -0.1+0.8i, 0.3-0.5i, -1.139+0.238i. ie, when 4 | asked for the real part, enter 0.3. For the imaginary, 5 | enter -.5 6 | } 7 | 8 | program julia; 9 | {$N+,E-} 10 | uses crt, Graph; 11 | Type Real = single; 12 | var 13 | cx, cy, 14 | xo, yo, x1, y1 : real; 15 | a, b, i, orb : word; 16 | gd, gm: integer; 17 | const 18 | MX = 640; { the box we want to plot on the screen } 19 | MY = 480; 20 | { cx = 0.3; 21 | cy = -0.5;} 22 | 23 | procedure InitGraphics; 24 | begin 25 | gd := InstallUserDriver('SVGA256', nil); 26 | if gd = grError then 27 | Halt (1); 28 | gm := 2; {640x480x256} 29 | InitGraph(gd,gm,''); { SetVMode(2);} 30 | if GraphResult <> grOk then 31 | Halt (2); 32 | end; 33 | 34 | begin 35 | write('Real part: '); 36 | readln(CX); 37 | write('Imaginary part: '); 38 | readln(CY); 39 | 40 | InitGraphics; 41 | 42 | FOR B := 0 TO Pred(MY) do {X screen coordinate} 43 | FOR A := 0 TO Pred(MX) do {Y screen coordinate} 44 | begin 45 | XO := -2.0 + A / MX * 4.0; {'X complex plane coordinate} 46 | YO := 2.0 - B / MY * 4.0; {'Y complex plane coordinate} 47 | Orb := 0; 48 | FOR I := 1 TO 255 do {iterations for 255 colors} 49 | begin 50 | X1 := Sqr(XO) - Sqr(YO) + CX; 51 | Y1 := 2.0 * XO * YO + CY; 52 | IF Sqr(X1) + Sqr(Y1) > 8.0 THEN {orbit escapes, plot it} 53 | begin 54 | Orb := I; 55 | break; 56 | END; 57 | XO := X1; 58 | YO := Y1; 59 | end; 60 | putpixel (round(A), round(B), Orb); {plot orbit} 61 | end; 62 | 63 | readln; 64 | CloseGraph; 65 | end. -------------------------------------------------------------------------------- /Graphics/PCX/TESTSAVE.PAS: -------------------------------------------------------------------------------- 1 | program WritePCX; 2 | 3 | uses 4 | Graph, PCX16,crt,dos; 5 | {-------------- DrawHorizBars ----------} 6 | procedure DrawHorizBars; 7 | var i, Color : word; 8 | begin 9 | cleardevice; 10 | Color := 15; 11 | for i := 0 to 15 do 12 | begin 13 | setfillstyle (solidfill,Color); 14 | bar (0,i*30,639,i*30+30); { 16*30 = 480 } 15 | dec (Color); 16 | end; 17 | end; 18 | {-------------- Main -------------------} 19 | var 20 | NameW : PathStr; 21 | Gd,Gm : integer; 22 | begin 23 | writeln; 24 | if (ParamCount = 0) then 25 | begin 26 | write ('Enter name of PCX picture file to write: '); 27 | readln (NameW); 28 | writeln; 29 | end 30 | else NameW:=paramstr(1); 31 | if (Pos ('.', NameW) = 0) then 32 | NameW := Concat(NameW, '.pcx'); 33 | 34 | Gd:=VGA; 35 | Gm:=VGAhi; {640x480, 16 colors} 36 | initgraph (Gd,Gm,'..\bgi'); { path to your EGAVGA.BGI } 37 | 38 | DrawHorizBars; 39 | 40 | readln; 41 | Save_PCX16(NameW); 42 | closegraph; { Close graphics } 43 | end. { Write_PCX } -------------------------------------------------------------------------------- /Graphics/SVGA/SVGADRV.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Graphics/SVGA/SVGADRV.OBJ -------------------------------------------------------------------------------- /Graphics/SVGA/SVGA_.PAS: -------------------------------------------------------------------------------- 1 | 2 | Unit SVGA_; 3 | 4 | Interface 5 | Uses Graph; 6 | 7 | const 8 | { Path:string[80]='E:\BP7\BGI';} 9 | { 256 colors } 10 | v320x200 : byte = 0; 11 | v640x480 : byte = 2; 12 | v800x600 : byte = 3; 13 | v1024x768 : byte = 4; 14 | v1280x1024 : byte = 5; 15 | 16 | Procedure SetVMode(Mode: byte); 17 | 18 | Implementation 19 | 20 | procedure SVGA_DRV; external; 21 | {$L svgadrv.obj} 22 | 23 | Procedure SetVMode; 24 | Var Gd,Gm: integer; 25 | Begin 26 | Gd:= InstallUserDriver('SVGA256',nil); 27 | if Gd= grError { Table full? } then 28 | begin 29 | writeln('Error of installing driver.'); 30 | Halt(1); 31 | end; 32 | if RegisterBGIdriver(@SVGA_DRV) < 0 then 33 | begin 34 | Writeln(GraphErrorMsg(GraphResult)); 35 | halt(2); 36 | end; 37 | Gm:=Mode; 38 | InitGraph(Gd,Gm,''); 39 | End; 40 | 41 | END. -------------------------------------------------------------------------------- /Graphics/SVGA/USE_SVGA.PAS: -------------------------------------------------------------------------------- 1 | 2 | uses Graph,SVGA_,convert; 3 | 4 | var MX,MY: integer; 5 | 6 | BEGIN 7 | SetVMode(v1024x768); 8 | SetColor(GetMaxColor div 3); 9 | MX:=GetMaxX; 10 | MY:=GetMaxY; 11 | line(0,0,MX,MY); 12 | OutTextXY(MX div 3,MY div 2,i2s(MX)+','+i2s(MY)); 13 | readln; 14 | CloseGraph; 15 | END. -------------------------------------------------------------------------------- /Hacker/PROTECT.pas: -------------------------------------------------------------------------------- 1 | Type 2 | BoolProc = function (s: string): boolean; 3 | PBoolProc = ^BoolProc; 4 | 5 | Const 6 | HashSum: longint = 3412; 7 | var 8 | str: string; 9 | 10 | Function Hash (Key: string): Longint; 11 | Var 12 | I, 13 | Sum:Integer; 14 | Begin 15 | Sum := 0; 16 | For I := 1 To Length (Key) Do 17 | Sum := Sum + (Ord (Key[I]) * (1 shl I)); 18 | Result := Sum; 19 | End; 20 | 21 | function Passed (ss: string): boolean; 22 | begin 23 | Result := (Hash (ss) = HashSum); 24 | end; 25 | 26 | procedure TestPsw (f: BoolProc); 27 | var 28 | b: boolean; 29 | begin 30 | b := f (str); 31 | writeln ('Passed test: ', b); 32 | end; 33 | 34 | var 35 | p: boolproc; 36 | pp: pointer; 37 | 38 | begin 39 | write ('Enter password: '); readln (str); 40 | pp := @Passed; 41 | TestPsw (PP); 42 | end. 43 | -------------------------------------------------------------------------------- /Hacker/Scr_cop2.pas: -------------------------------------------------------------------------------- 1 | 2 | uses Crt; 3 | 4 | Type 5 | TCharAttr = packed record 6 | ch : Char; 7 | attr : Byte; 8 | end; 9 | PConsoleBuf = ^TConsoleBuf; 10 | TConsoleBuf = Array[0..ConsoleMaxX*ConsoleMaxY-1] of TCharAttr; 11 | 12 | Const 13 | ScreenSize = SizeOf (TConsoleBuf); 14 | PageSize: word = 80*25*2; 15 | VSize : Word = $1000; { Full page size } 16 | 17 | Type 18 | TArrByte = array [1..ScreenSize] Of byte; 19 | PArrByte = ^TArrByte; 20 | 21 | 22 | Var 23 | Buf: pointer; 24 | 25 | Begin 26 | ClrScr; 27 | writeln ('Copy screen to buffer test.'); 28 | 29 | GetMem(Buf, PageSize); 30 | If Buf = Nil Then 31 | Begin 32 | Writeln('Not enough memory for Screen buf'); 33 | Halt; 34 | End; 35 | 36 | Writeln('This sample for text direct copy'); 37 | Move (ConsoleBuf^, Buf^, ScreenSize); 38 | readln; 39 | 40 | ClrScr; 41 | writeln ('Screen comes back...'); 42 | readln; 43 | 44 | Move (Buf^, ConsoleBuf^, ScreenSize); 45 | readln; 46 | 47 | FreeMem(Buf, PageSize); 48 | End. 49 | -------------------------------------------------------------------------------- /Hacker/Scr_copy.pas: -------------------------------------------------------------------------------- 1 | 2 | uses Crt; 3 | 4 | Const TextScreenBuf = SegB000; 5 | ScreenSize = 80*25*2; 6 | PageSize: word = 80*25*2; 7 | VSize : Word = $1000; { Full page size } 8 | 9 | Type 10 | TArrByte = array [1..ScreenSize] Of byte; 11 | PArrByte = ^TArrByte; 12 | 13 | 14 | Var 15 | Screen, 16 | Buf: PArrByte; 17 | k: word; 18 | p: PChar; 19 | s:string; 20 | 21 | Begin 22 | ClrScr; 23 | writeln ('Copy screen to buffer test.'); 24 | 25 | readln; 26 | 27 | // Screen := pointer (SegB800); 28 | // Screen := ptr (SegB800,0); 29 | p := $B8000; 30 | k := 0; 31 | while k < PageSize do 32 | begin 33 | write (chr(Mem[segB800:k])); 34 | inc (k,2); 35 | end; 36 | k:=$1111; 37 | exit; 38 | 39 | (* 40 | GetMem (Buf, PageSize); 41 | If Buf = Nil Then 42 | Begin 43 | Writeln ('Not enough memory for Screen buf'); 44 | Halt; 45 | End; 46 | 47 | // MemL[segB800:VSize*page] 48 | Writeln ('This sample for text direct copy'); 49 | Move (Screen^, Buf^, ScreenSize); 50 | // MyMove(Screen^,Buf^,ScreenSize); 51 | readln; 52 | 53 | ClrScr; 54 | writeln ('Screen comes back...'); 55 | readln; 56 | 57 | Move (Buf^, Screen^, ScreenSize); 58 | readln; 59 | 60 | FreeMem (Buf, PageSize); 61 | *) 62 | End. 63 | -------------------------------------------------------------------------------- /Hacker/bruteforce.pas: -------------------------------------------------------------------------------- 1 | 2 | type 3 | Tcharset = set of char; 4 | 5 | const 6 | psw : string[30] = 'topsecret'; 7 | abc_ : string[30] = 'abcdefghijklmnopqrstuvwxyz'; 8 | abc : string[30] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; 9 | digits : string[10] = '0123456789'; 10 | special : string[30] = ' _@.'; 11 | special_plus : string[30] = ',-[]<>!?#*=~$%^&'; 12 | 13 | var 14 | SDict: string; { словарь, состоящий из перебираемых символов} 15 | 16 | procedure BruteForce(S: string; n: integer); {процедура, которая будет составлять пароли} 17 | var 18 | i: integer; 19 | begin 20 | for i := 1 to Length (SDict) do 21 | begin 22 | s[n] := SDict[i]; 23 | if n = 1 then 24 | begin 25 | if s = psw then 26 | writeln ('Found! psw: ', s) 27 | end 28 | else 29 | BruteForce(s, n - 1); 30 | end; 31 | end; 32 | 33 | var 34 | SBase: string; 35 | begin 36 | SBase := 'aaaaaaaaaaa'; {задаешь длину пароля} 37 | SDict := abc_ + special; {набор символов(из чего перебор состоять будет)} 38 | BruteForce (SBase, Length(SBase)); {вызов процедуры, котоая составляет пассы} 39 | end. 40 | -------------------------------------------------------------------------------- /Hacker/xor_rec.pas: -------------------------------------------------------------------------------- 1 | program xor_record; 2 | 3 | type 4 | TRec = record 5 | f1, f2: Integer; 6 | f3: String; 7 | end; 8 | 9 | XX = array [1..SizeOf (TRec)] of byte; 10 | PX = ^XX; 11 | 12 | var 13 | X: PX; 14 | Rec: TRec; 15 | Recsize, 16 | i: integer; 17 | 18 | begin 19 | readln (Rec.f1); 20 | readln (Rec.f2); 21 | 22 | X := @Rec; 23 | Recsize := SizeOf (TRec); 24 | 25 | for i := 1 to Recsize do 26 | X^[i] := X^[i] xor lo (Recsize); 27 | 28 | readln; 29 | end. -------------------------------------------------------------------------------- /Lib/CYRILLIC.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Lib/CYRILLIC.PAS -------------------------------------------------------------------------------- /Lib/DEBUG.INC: -------------------------------------------------------------------------------- 1 | {.$DEFINE DEBUG.} 2 | {$DEFINE Error_Checking} 3 | {$IFDEF Error_Checking} 4 | {$I+} {L I/O Checking } 5 | {$Q+} {L Overflow Checking } 6 | {$R+} {L Range Checking } 7 | {$S+} {L Stack Overflow Checking } 8 | {$ELSE} 9 | {$I-} {L I/O Checking } 10 | {$Q-} {L Overflow Checking } 11 | {$R-} {L Range Checking } 12 | {$S-} {L Stack Overflow Checking } 13 | {$ENDIF} 14 | {$UNDEF Error_Checking} 15 | 16 | {$IFDEF DEBUG} 17 | {$D+} {G Debug Information } 18 | {$L+} {G Local Symbol Information } 19 | {$Y+} {G Symbolic Reference Information } 20 | {$ELSE} 21 | {$D-} {G Debug Information } 22 | {$L-} {G Local Symbol Information } 23 | {$Y-} {G Symbolic Reference Information } 24 | {$ENDIF} 25 | 26 | {$A+} {G Align Data} 27 | {$B-} {L Short Circuit Boolean Evaluation } 28 | {$E+} {G Enable Emulation } 29 | {$G+} {G Generate 80286 Code } 30 | {$N-} {G Disable Numeric Processing } 31 | {$P+} {G Enable Open Parameters } 32 | {$T+} {G Type @ Operator } 33 | {$V+} {L Var String Checking } 34 | {$X+} {G Extended Syntax Enabled } 35 | {=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=} -------------------------------------------------------------------------------- /Lib/KEYCODE.INC: -------------------------------------------------------------------------------- 1 | const 2 | Enter = #13; Tab = #9; BS = #8; 3 | Esc = #27; Space = #32; SH_Tab = #15; 4 | Rt = #77; Lf = #75; 5 | Up = #72; Dn = #80; 6 | PgUp = #73; PgDn = #81; 7 | Ins = #82; Del = #83; Home = #71; EndK = #79; 8 | F1 = #59; F2 = #60; F3 = #61; F4 = #62; F5 = #63; 9 | F6 = #64; F7 = #65; F8 = #66; F9 = #67; F10 = #68; 10 | F11 = #133; F12= #134; 11 | ALT_Q = #16; ALT_W = #17; ALT_E = #18; ALT_R = #19; 12 | ALT_T = #20; ALT_Y = #21; ALT_U = #22; ALT_I = #23; 13 | ALT_O = #24; ALT_P = #25; ALT_A = #30; ALT_S = #31; 14 | ALT_D = #32; ALT_F = #33; ALT_G = #34; ALT_H = #35; 15 | ALT_J = #36; ALT_K = #37; ALT_L = #38; ALT_Z = #44; 16 | ALT_X = #45; ALT_C = #46; ALT_V = #47; ALT_B = #48; 17 | ALT_N = #49; ALT_M = #50; ALT_SP = #2; -------------------------------------------------------------------------------- /Lib/OVR_INIT.PAS: -------------------------------------------------------------------------------- 1 | Unit ovr_init; 2 | {$X+} 3 | Interface 4 | 5 | Implementation 6 | Uses overlay,crt; 7 | const ovrbufsize=$18000; {$10000;} 8 | begin 9 | OvrInit(paramstr(0)); 10 | if OvrResult<>OvrOk then 11 | begin 12 | case OvrResult of 13 | OvrNotFound:writeln('Overlay file not found.'); 14 | else writeln('Error initialization of overlay file.'); 15 | end; 16 | halt(1); 17 | end; 18 | ovrInitEMS; 19 | if OvrResult<>ovrOk then 20 | begin 21 | write('Overlay not loaded to EMS: '); 22 | case OvrResult of 23 | ovrIOError: writeln('I/O error access to overlay file'); 24 | ovrNoEMSDriver: writeln('EMS driver not found'); 25 | ovrNoEMSMemory: writeln('Not enough EMS memory') 26 | end; 27 | writeln('Using base memory.'); 28 | writeln(#13#10'Press any key...'); 29 | wait; 30 | end; 31 | ovrSetBuf(ovrbufsize); 32 | if OvrResult<>OvrOk then 33 | begin 34 | write('Initialization error of overlay buffer: '); 35 | if OvrResult=ovrNoMemory then 36 | write('Not enough memory for Ovrbuffer'); 37 | writeln(#13#10'Press any key...'); 38 | wait; 39 | halt(2); 40 | end 41 | end. -------------------------------------------------------------------------------- /Lib/STR2NUM.INC: -------------------------------------------------------------------------------- 1 | 2 | function L2S(I: Longint): String; 3 | { Convert any integer type to a string } 4 | var 5 | S: string[11]; 6 | begin 7 | Str(I, S); 8 | L2S := S; 9 | end; 10 | 11 | function I2S(I: integer): String; 12 | var 13 | S: string[6]; 14 | begin 15 | Str(I, S); 16 | I2S := S; 17 | end; 18 | -------------------------------------------------------------------------------- /Lib/STRUTIL.PAS: -------------------------------------------------------------------------------- 1 | Unit StrUtil; 2 | 3 | INTERFACE 4 | 5 | Function CopyFromTo(source:string; _From,_To: byte):string; 6 | Procedure TruncStr (var TS:string; From: byte); 7 | Function LastPos (c: char; Str: string): byte; 8 | Function Capitalize(S:String):String; {Capitalize The First Letter Of Each Word} 9 | Function Center (S: String; Len: Byte): String; 10 | Function DelBeg (s: String):string; { delete all spaces from beginning } 11 | Function DelEnd (s: String):string; { delete all spaces from end } 12 | {****************************************************************************} 13 | 14 | IMPLEMENTATION 15 | Function JustifyR (S: String; Len: Byte): String; 16 | Begin 17 | JustifyR := S; 18 | if Length(S) < Len then 19 | JustifyR := FillStr(' ',(Len - Length(S))) + S; 20 | End; 21 | {---------------} 22 | Function JustifyL (S: String; Len: Byte): String; 23 | Begin 24 | JustifyL := S; 25 | if Length(S) < Len then 26 | JustifyL := S + FillStr(' ',(Len - Length(S))); 27 | End; 28 | {---------------} 29 | Function BreakSum (R: String; Symb: Char): String; 30 | Var 31 | i, j: Byte; 32 | P, K: String; 33 | 34 | Function DelTrash(S: String): String; 35 | var P: string; 36 | i:byte; 37 | Begin 38 | P := ''; 39 | For i := 1 to Length(S) do 40 | if (S[i]='.') or IsDigit(S[i]) then 41 | P := P + S[i]; 42 | DelTrash := P 43 | End; 44 | 45 | Function Reverse(S: String): String; 46 | var P: string; 47 | i:byte; 48 | Begin 49 | P := ''; 50 | For i := Length(S) downto 1 do 51 | P := P + S[i]; 52 | End; 53 | 54 | Begin 55 | P:=Reverse(DelTrash(R)); 56 | K:=LeftEnd(P,'.'); 57 | j := 0; 58 | For i:=1 to Length(P) do 59 | Begin 60 | if j = 3 then 61 | Begin 62 | K := K + Symb; 63 | j := 0; 64 | End; 65 | K := K + P[i]; 66 | Inc(j); 67 | End; 68 | P:=Reverse(K); 69 | if CPos('.', P) = 0 then 70 | P := P + '.00'; 71 | BreakSum := P; 72 | End; 73 | {---------------} 74 | Function DelBeg(s: String):string; 75 | var Len: Byte absolute s; 76 | begin 77 | While ((s[1]=' ')or(s[len]=#9))and(Len>0) do Delete(s, 1, 1); 78 | DelBeg:=s; 79 | end; 80 | {---------------} 81 | Function DelEnd(s: String):string; 82 | var Len: Byte absolute s; 83 | begin 84 | While ((s[len]=' ')or(s[len]=#9)) and (Len>0) do Dec(Len); 85 | DelEnd:=s; 86 | end; 87 | {---------------} 88 | Function Center (S: String; Len: Integer): String; 89 | Begin 90 | if Len < Length(S) then 91 | Center:= S 92 | else 93 | Center:= FillStr(' ',(Len - Length(S)) shr 1) + S; 94 | End; 95 | {---------------} 96 | Function Capitalize(S:String):String; 97 | var I:byte; 98 | begin 99 | LoStr(S); 100 | S[1]:=UpCase(S[1]); 101 | For I:=1 to Length(S)-1 do 102 | If (S[I]=' ') or (S[I]='.') then 103 | S[i+1]:=UpCase(S[i+1]); 104 | Capitalize:=S; 105 | end; 106 | 107 | END. -------------------------------------------------------------------------------- /Lib/bcdto.pas: -------------------------------------------------------------------------------- 1 | 2 | function LHEXFN (decimal : longint) : string; 3 | const hexDigit : array [0..15] of char = '0123456789ABCDEF'; 4 | var i : byte; 5 | s : string; 6 | begin 7 | FillChar (s, SizeOf(s), ' '); 8 | s[0] := chr(8); 9 | for i := 0 to 7 do 10 | s[8-i] := HexDigit[(decimal shr (4*i)) and $0F]; 11 | lhexfn := s; 12 | end; (* lhexfn *) 13 | {} 14 | 15 | function DecToBCD (x : longint; var ok : boolean) : longint; 16 | const Digit : array [0..9] of char = '0123456789'; 17 | var hexStr : string; 18 | var i, k : byte; 19 | y, d : longint; 20 | begin 21 | hexStr := LHEXFN(x); 22 | y := 0; 23 | d := 1; 24 | ok := false; 25 | for i := 7 downto 0 do begin 26 | k := Pos (hexStr[i+1], Digit); 27 | if k = 0 then exit; 28 | y := y + (k-1) * d; 29 | if i > 0 then d := 10 * d; 30 | end; { for } 31 | ok := true; 32 | DecToBCD := y; 33 | end; (* dectobcd *) 34 | 35 | Function Dec2Bin (num: word): String; 36 | var result: string; 37 | remainder: word; 38 | c: char; 39 | begin 40 | result := ''; 41 | while num <> 0 do 42 | begin 43 | remainder := num mod 2; 44 | num := num div 2; { ??? num := num shr 1 } 45 | c := chr (remainder + ord ('0')); 46 | result := c + result; 47 | end; 48 | Dec2Bin := result 49 | end; 50 | 51 | function BCD(X : word) : word; 52 | begin BCD := (X div 10)*16 + (X mod 10) end ; 53 | 54 | var i : byte; 55 | x10 : longint; 56 | xBCD : longint; 57 | ok : boolean; 58 | begin 59 | x10 := 10; 60 | writeln ('The ordinary decimal value : ', x10); 61 | xBCD := DecToBCD (x10, ok); 62 | if ok then writeln ('is ', xBCD, ' as a binary coded decimal') 63 | else writeln ('Error in BCD'); 64 | writeln (BCD (x10)); 65 | readln; 66 | end. 67 | -------------------------------------------------------------------------------- /Lib/bits.inc: -------------------------------------------------------------------------------- 1 | Function IsbitOn (n: word; b : BYTE): BOOLEAN; 2 | BEGIN isBitOn:=((n SHR b) AND 1) = 1 END; 3 | 4 | Procedure SetBitOn (VAR n: Word; b: BYTE); 5 | BEGIN N:= N OR (1 SHL b) END; 6 | 7 | Procedure XORBit (VAR n: Word; b: BYTE); 8 | BEGIN N:= N XOR (1 SHL b) END; 9 | -------------------------------------------------------------------------------- /Lib/err_trap.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Lib/err_trap.pas -------------------------------------------------------------------------------- /Math/8DIGITS.PAS: -------------------------------------------------------------------------------- 1 | { 2 | Дано натур. число N. Определить кол-во 8 значных чисел, 3 | у которых сумма цифр в цифровой записи числа меньше, чем N. 4 | Если таких чисел нет, выводим НЕТ. 5 | } 6 | 7 | program _8digits; 8 | 9 | function SumOfDigits (x: longint): integer; 10 | var 11 | rem, 12 | sum: integer; 13 | begin 14 | sum := 0; 15 | While X <> 0 Do 16 | Begin 17 | rem := X Mod 10; 18 | inc (sum, rem); 19 | X:=X Div 10; 20 | End; 21 | SumOfDigits := sum; 22 | end; 23 | 24 | var 25 | n, count: integer; 26 | i : longint; 27 | 28 | begin 29 | write ('Enter 1 <= n <= 72 : '); readln (n); 30 | count := 0; 31 | 32 | for i := 10000000 to 99999999 do 33 | begin 34 | if i mod 10000 = 0 then 35 | writeln (i); 36 | if SumOfDigits (i) < N then 37 | inc(count); 38 | end; 39 | 40 | if count = 0 then 41 | writeln('none') 42 | else 43 | writeln('count = ', count); 44 | readln; 45 | end. 46 | -------------------------------------------------------------------------------- /Math/Calculus/ANALIZE/ANALIZE.MSG: -------------------------------------------------------------------------------- 1 | Hello, All! 2 | 3 | ‚®в. ќв  ивгЄ  Ўл«  ­ ЇЁб ­  Ј®¤  3 ­ § ¤ Ё § ­Ё¬ Ґвбп бЁ¬ў®«м­л¬ 4 | ¤ЁддҐаҐ­жЁа®ў ­ЁҐ¬ (в® ЎЁим, ­  ўе®¤Ґ 'sin(x*x)' => ­  ўл室Ґ '2*x*cos(x*x)' Ё 5 | в.¤.). ‚தҐ, ¤®ў®«м­® nice, ­Ґб¬®вап ­  ­ҐЄ®в®аго ЇаЁ¬ЁвЁў­®бвм( бЄ®Ў®Є, 6 | § а § , ¬­®Ј® Ї«®¤Ёв,   бЁ¬ў®«м­л© 'гЇа®бвЁвҐ«м' бгйҐб⢥­­® ¤«Ё­­ҐҐ ;). 7 | „ ©, ¤г¬ о, «о¤џ¬ Ї®¤ ао - ¬®¦Ґв, ЇаЁЈ®¤Ёвбп Є®¬г ;-D. 8 | 9 | Regards, 10 | Alexey 11 | aka alex@pd.spb.su 12 | 13 | Enough! or Too much. 14 | 15 | --- Beta5+ 16 | * Origin: Hollow Hills (FidoNet 2:5030/87.55) 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /Math/Calculus/ANALIZE/ANALIZE.PAS: -------------------------------------------------------------------------------- 1 | program Analize; 2 | 3 | type 4 | diagrams = record 5 | ops, text : string; 6 | end; 7 | 8 | const 9 | max = 9; 10 | all : array [1..max] of diagrams = ( 11 | ( ops:'+'; text: '($<)+($>)'), 12 | ( ops:'-'; text: '($<)-($>)'), 13 | ( ops:'*'; text: '($<)*(>)+($>)*(<)'), 14 | ( ops:'/'; text: '(($<)*(>)-($>)*(<))/((>)*(>))'), 15 | ( ops:'sin'; text: 'cos(>)*($>)'), 16 | ( ops:'cos'; text: '($>)*(-sin(>))'), 17 | ( ops:'exp'; text: '(($>)*exp(>))'), 18 | ( ops:'ln'; text: '($>)/(>)'), 19 | ( ops:'x'; text: '1') ); 20 | 21 | var str : string[60]; 22 | 23 | procedure find_simb (beg,end1:integer;wanted:string;var pos1,pos2:integer); 24 | var 25 | i,bc,k,n : integer; 26 | fl : boolean; 27 | begin 28 | bc := 0; n:=Length(wanted); 29 | for i:=beg to end1 do begin 30 | fl:=true; 31 | for k:=0 to n-1 do 32 | if (str[i+k]<>wanted[k+1]) then begin fl := false; break end; 33 | if((fl)and(bc=0)) then break; 34 | if (str[i]='(') then Inc(bc); 35 | if (str[i]=')') then Dec(bc); 36 | end; 37 | pos1:=i; 38 | pos2:=i+n-1; 39 | if not(fl) then pos2:=end1+1; 40 | end; 41 | 42 | function df(beg,end1:integer):string; 43 | var 44 | st,sx,cur_adr : string; 45 | ch : char; 46 | i,j,pos1,pos2,uk : integer; 47 | begin 48 | st:='';sx:=''; 49 | if (str[beg]='(') then begin find_simb(beg+1,end1,')',pos1,pos2); 50 | if (pos2>end1-1) then begin 51 | df := df(beg+1,pos2-1); 52 | exit 53 | end; 54 | end; 55 | for i:=1 to max do begin 56 | find_simb(beg,end1,all[i].ops,pos1,pos2); 57 | if(pos2<=end1) then begin 58 | cur_adr:=all[i].text; 59 | uk := 0; 60 | while (uk' : begin for j:=pos2+1 to end1 do sx[j-pos2]:=str[j]; 73 | sx[0]:=chr(end1-pos2); 74 | end; 75 | else sx:=ch; 76 | end; { case } 77 | st:=st+sx; 78 | end; { while } 79 | df:=st; exit; 80 | end; { if } 81 | end; { for } 82 | df:='0'; 83 | end; { df } 84 | 85 | begin 86 | Readln(Str); 87 | while Str<>'' do begin 88 | Writeln( df(1, Length(Str)) ); 89 | Readln( Str ); 90 | end; 91 | end. 92 | 93 | -------------------------------------------------------------------------------- /Math/Calculus/CALCLEN.PAS: -------------------------------------------------------------------------------- 1 | {$N+} 2 | type 3 | fofx = function(x : real) : real; { needed for function-evaluating } 4 | 5 | function derivative(x, dx : real; f : pointer) : real; 6 | var y : fofx; 7 | begin 8 | @y := f; 9 | derivative := (y(x + dx/2) - y(x - dx/2)) / dx; 10 | end; 11 | 12 | { Integrates function from a to b, 13 | by approximating function with 14 | rectangles of width h. } 15 | function integral(a, b, h : real; f : pointer) : real; 16 | var 17 | x, summation : real; 18 | y : fofx; 19 | begin 20 | @y := f; 21 | summation := 0; 22 | x := a + h/2; 23 | while x < b do 24 | begin 25 | summation:= summation + h * 26 | sqrt( sqr(y(x)) + sqr( derivative(x,h,f) ) ); {Integral Expression} 27 | x:=x+h; 28 | end; 29 | integral := summation; 30 | end; 31 | 32 | function Length(a, b, h : real; f : pointer) : real; 33 | begin 34 | Length:=integral(a,b,h,f); 35 | end; 36 | 37 | function F(x : real) : real; FAR; 38 | begin 39 | F:=1.0-sin(x); 40 | end; 41 | 42 | begin 43 | writeln('Curve length:',Length(-pi/2,-pi/6, 1e-4, @F):8:5); 44 | readln; 45 | end. -------------------------------------------------------------------------------- /Math/Calculus/SURFACES.PAS: -------------------------------------------------------------------------------- 1 | uses calculus; 2 | 3 | var answer,xx,yy : real; 4 | {$F+} { WARNING! YOU NEED "FAR" FUNCTIONS! } 5 | Function y(x : real) : real; 6 | begin 7 | y:=10-sqrt(x); 8 | end; 9 | 10 | begin 11 | writeln('Function: y = 10-sqrt(x)'); 12 | writeln; 13 | 14 | answer := Length(1, 2, 0.001, @y); 15 | writeln('Length: ', answer:1:3); 16 | 17 | answer := Surface(1, 2, 0.001, @y); 18 | writeln('Surface: ', answer:1:3); 19 | 20 | answer := Volume(1, 2, 0.001, @y); 21 | writeln('Volume: ', answer:1:3); 22 | 23 | CenterTr(1, 2, 0.001, @y, xx, yy); 24 | writeln('Center of trapezoid: (', xx:1:3,', ', yy:1:3,')'); 25 | 26 | end. -------------------------------------------------------------------------------- /Math/Calculus/TESTCALC.PAS: -------------------------------------------------------------------------------- 1 | program testcalc; 2 | uses 3 | calculus; 4 | 5 | var 6 | answer : real; 7 | 8 | {$F+} { WARNING! YOU NEED "FAR" FUNCTIONS! } 9 | function y(x : real) : real; 10 | begin 11 | y := 4 * sqrt(1 - x * x); 12 | end; 13 | 14 | begin 15 | writeln('Function: y = (1 - x^2)^(1/2) (i.e., top half of a circle)'); 16 | writeln; 17 | 18 | { Calc operations here are: } 19 | 20 | { Integrate function from 0 to 1, in increments of 0.001. A quarter circle. } 21 | { Get slope of function at 0 by evaluating points 0.01 away from each other. } 22 | { Find extremum of function, starting at 0.4, initially looking at points 23 | 0.1 on either side of 0.4, and not stopping until we have two x-values 24 | within 0.001 of each other. } 25 | 26 | answer := integral(0, 1, 0.001, @y); 27 | writeln('Integral: ', answer:13:9); 28 | 29 | answer := derivative (0, 0.01, @y); 30 | writeln('Derivative: ', answer:13:9); 31 | 32 | answer := extremum(0.4, 0.1, 0.001, @y); 33 | writeln('Extremum: ', answer:13:9); 34 | end. -------------------------------------------------------------------------------- /Math/Calculus/approx.pas: -------------------------------------------------------------------------------- 1 | {$N+} 2 | 3 | const Eps=1e-5; 4 | 5 | function F(value: double): double; 6 | begin 7 | F:= value*value - 12.0; 8 | end; 9 | 10 | var x,z: double; 11 | itt: integer; 12 | 13 | begin 14 | write('Enter first approximation: '); readln(z); 15 | x:=F(z); 16 | itt:=0; 17 | repeat 18 | z:=x; 19 | x:=F(z); 20 | inc(itt); 21 | until abs(x-z) EOF) do 33 | adler := adler32(adler, buffer, length); 34 | 35 | if (adler <> original_adler) then 36 | error(); 37 | end; 38 | } 39 | 40 | implementation 41 | 42 | const 43 | BASE = Long(65521); { largest prime smaller than 65536 } 44 | {NMAX = 5552; original code with unsigned 32 bit integer } 45 | { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } 46 | NMAX = 3854; { code with signed 32 bit integer } 47 | { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } 48 | { The penalty is the time loss in the extra MOD-calls. } 49 | 50 | 51 | { ========================================================================= } 52 | 53 | function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; 54 | var 55 | s1, s2 : uLong; 56 | k : int; 57 | begin 58 | s1 := adler and $ffff; 59 | s2 := (adler shr 16) and $ffff; 60 | 61 | if not Assigned(buf) then 62 | begin 63 | adler32 := uLong(1); 64 | exit; 65 | end; 66 | 67 | while (len > 0) do 68 | begin 69 | if len < NMAX then 70 | k := len 71 | else 72 | k := NMAX; 73 | Dec(len, k); 74 | { 75 | while (k >= 16) do 76 | begin 77 | DO16(buf); 78 | Inc(buf, 16); 79 | Dec(k, 16); 80 | end; 81 | if (k <> 0) then 82 | repeat 83 | Inc(s1, buf^); 84 | Inc(puf); 85 | Inc(s2, s1); 86 | Dec(k); 87 | until (k = 0); 88 | } 89 | while (k > 0) do 90 | begin 91 | Inc(s1, buf^); 92 | Inc(s2, s1); 93 | Inc(buf); 94 | Dec(k); 95 | end; 96 | s1 := s1 mod BASE; 97 | s2 := s2 mod BASE; 98 | end; 99 | adler32 := (s2 shl 16) or s1; 100 | end; 101 | 102 | { 103 | #define DO1(buf,i) 104 | begin 105 | Inc(s1, buf[i]); 106 | Inc(s2, s1); 107 | end; 108 | #define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); 109 | #define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); 110 | #define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); 111 | #define DO16(buf) DO8(buf,0); DO8(buf,8); 112 | } 113 | end. 114 | 115 | -------------------------------------------------------------------------------- /Math/Checksum/ZCONF.INC: -------------------------------------------------------------------------------- 1 | { -------------------------------------------------------------------- } 2 | 3 | {$DEFINE MAX_MATCH_IS_258} 4 | 5 | { Compile with -DMAXSEG_64K if the alloc function cannot allocate more 6 | than 64k bytes at a time (needed on systems with 16-bit int). } 7 | 8 | {$DEFINE MAXSEG_64K} 9 | {$IFNDEF WIN32} 10 | {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } 11 | {$ENDIF} 12 | 13 | {$UNDEF DYNAMIC_CRC_TABLE} 14 | {$UNDEF FASTEST} 15 | {$define patch112} { apply patch from the zlib home page } 16 | { -------------------------------------------------------------------- } -------------------------------------------------------------------------------- /Math/Discrete/srhbranch.pas: -------------------------------------------------------------------------------- 1 | { Поиск всех возможных маршрутов между двумя точками графа } 2 | program all_road; 3 | const 4 | N=7;{ кол-во вершин графа} 5 | var 6 | map:array[1..N,1..N] of integer;{ Карта: map[i,j] не 0, 7 | если точки i и j соединены } 8 | road:array[1..N] of integer;{ Маршрут - номера точек карты } 9 | incl:array[1..N] of boolean;{ incl[i]=TRUE, если точка } 10 | { с номером i включена в road } 11 | 12 | start,finish:integer;{ Начальная и конечная точки } 13 | 14 | i,j:integer; 15 | 16 | procedure step(s,f,p:integer);{ s - точка, из которой делается шаг} 17 | { f - конечная точка маршрута} 18 | { p - номер искомой точки маршрута} 19 | var 20 | c:integer;{ Номер точки, в которую делается очередной шаг } 21 | begin 22 | if s=f then begin 23 | {Точки s и f совпали!} 24 | write('Путь: '); 25 | for i:=1 to p-1 do write(road[i],' '); 26 | writeln; 27 | end 28 | else begin 29 | { Выбираем очередную точку } 30 | for c:=1 to N do begin { Проверяем все вершины } 31 | if(map[s,c]<>0)and(NOT incl[c]) 32 | { Точка соединена с текущей и не включена } 33 | { в маршрут} 34 | then begin 35 | road[p]:=c;{ Добавим вершину в путь } 36 | incl[c]:=TRUE;{ Пометим вершину } 37 | { как включенную } 38 | step(c,f,p+1); 39 | incl[c]:=FALSE; 40 | road[p]:=0; 41 | end; 42 | end; 43 | end; 44 | end;{ конец процедуры step } 45 | 46 | { Основная программа } 47 | begin 48 | { Инициализация массивов } 49 | for i:=1 to N do road[i]:=0; 50 | for i:=1 to N do incl[i]:=FALSE; 51 | for i:=1 to N do for j:=1 to N do map[i,j]:=0; 52 | { Ввод значений элементов карты } 53 | map[1,2]:=1; map[2,1]:=1; 54 | map[1,3]:=1; map[3,1]:=1; 55 | map[1,4]:=1; map[4,1]:=1; 56 | map[3,4]:=1; map[4,3]:=1; 57 | map[3,7]:=1; map[7,3]:=1; 58 | map[4,6]:=1; map[6,4]:=1; 59 | map[5,6]:=1; map[6,5]:=1; 60 | map[5,7]:=1; map[7,5]:=1; 61 | map[6,7]:=1; map[7,6]:=1; 62 | write('Введите через пробел номера начальной и конечной точек -> '); 63 | readln(start,finish); 64 | road[1]:=start;{ Внесем точку в маршрут } 65 | incl[start]:=TRUE;{ Пометим ее как включенную } 66 | 67 | step(start,finish,2);{Ищем вторую точку маршрута } 68 | 69 | writeln('Для завершения нажмите '); 70 | readln; 71 | end. 72 | 73 | -------------------------------------------------------------------------------- /Math/FunctionParser/TSTPARS.pas: -------------------------------------------------------------------------------- 1 | 2 | uses FParser; 3 | 4 | Const 5 | Expression = 'x * ln(x) - (x + 1)^3'; 6 | 7 | var 8 | ExpressionParser: TParsedFunction; 9 | erc: integer; 10 | f: single; 11 | 12 | begin 13 | Writeln ('Results of function Y(x) = ',Expression); 14 | ExpressionParser.ParseFunction (Expression, erc); 15 | 16 | f := 0.2; 17 | while f < 1.4 do 18 | begin 19 | Writeln ('Y(', f:1:2,') = ', 20 | ExpressionParser.Compute (f, 0, 0) : 4 : 2); 21 | f := f + 0.2; 22 | end; 23 | end. -------------------------------------------------------------------------------- /Math/Geometry/3DMISC.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/Math/Geometry/3DMISC.PAS -------------------------------------------------------------------------------- /Math/Geometry/poly.pas: -------------------------------------------------------------------------------- 1 | { 2 | Code by VanDamM // [WRC] 3 | } 4 | 5 | Program Check_Point_In_Poly; 6 | Uses Crt; 7 | 8 | Type Point = Record { тип точка } 9 | x, y : integer; 10 | End; 11 | 12 | Var PointXY : Point; { проверяемая точка } 13 | Poly : array[0..24] of Point; { массив вершин многоугольника } 14 | C : integer; { кол-во вершин многоугольника } 15 | i, j : integer; 16 | 17 | Function Max( Num1, Num2 : integer ) : integer; 18 | Begin 19 | If Num1>Num2 then Max:=Num1 else Max:=Num2; 20 | End; 21 | 22 | Function Min( Num1, Num2 : integer ) : integer; 23 | Begin 24 | If Num1 A.y) and (p[j].y > A.y) then Continue; 48 | If (P[i].y < A.y) and (p[j].y < A.y) then Continue; 49 | If Max(P[i].y, P[j].y) = A.y then 50 | Inc(Count) 51 | else 52 | If Min(P[i].y, P[j].y) = A.y then 53 | Continue 54 | else 55 | begin 56 | T := (A.y-P[i].y)/(P[j].y-P[i].y); 57 | If ((T>0) and (T<1)) and ((P[i].x + T*(P[j].x-P[i].x)) >= A.x) then 58 | Inc(Count); 59 | end; 60 | end; 61 | PointInPoly:= Count AND 1; 62 | End; 63 | 64 | Begin 65 | ClrScr; 66 | 67 | EnterData; 68 | 69 | repeat 70 | WriteLn; 71 | Write('Point X: '); ReadLn(PointXY.x); 72 | Write('Point Y: '); ReadLn(PointXY.y); 73 | 74 | writeln; 75 | 76 | If PointInPoly(PointXY, Poly, C) = 0 then 77 | Write('Answer: Point out of poly') 78 | else 79 | Write('Answer: Point in poly'); 80 | until PointXY.x = -1; 81 | 82 | 83 | readln; 84 | End. 85 | -------------------------------------------------------------------------------- /Math/Optimization/LABA0.TXT: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | ЗАДАНИЕ : 9 | 10 | Найти минимум заданной функции на заданном пpомежутке 11 | 12 | методами первого порядка и построить графики функции с 13 | 14 | отображением первых итераций и пpовести анализ полученных 15 | 16 | данных. 17 | 18 | 19 | 20 | ПЕРВАЯ ФУНКЦИЯ 21 | 22 | 23 | 24 | 25 | Эллиптический параболоид 26 | a = 1 27 | b = -5 28 | c = 1 29 | d = 4 30 | alpha = 145 31 | 32 | 33 | ВТОРАЯ ФУНКЦИЯ 34 | 35 | 36 | 37 | Функция Розенброка 38 | 39 | f=100(x2-x1^2)+(1-x1)^2 40 | 41 | 42 | 43 | 44 | ТОЧНОСТЬ : 45 | 46 | 47 | eps = 0.001 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /Math/Optimization/LABA1.TXT: -------------------------------------------------------------------------------- 1 | 2 | В качестве исследоваемых 3 | методов были взяты метод наискорейшего спуска 4 | и метод сопряженного градиента. 5 | 6 | 7 | 8 | 9 | 10 | Метод наискорейшего спуска 11 | В основе метода лежит понятие 12 | антиградиента - направления наибольшего 13 | возрастания функции . Делается шаг по 14 | направлению антиградиента в точке так , 15 | чтобы новая точка была "лучшей" в данном 16 | направлении. Критерием окончания является 17 | градиент (или антиградиент) функции в 18 | точке - он должен быть равным 0 по 19 | свойству экстремума. 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | Метод сопряженного градиента 28 | Метод основан на том же понятии. Первая 29 | итерация делается как в методе наискорей- 30 | шего спуска. Далее новое направление на- 31 | ходится как суммма антиградиента и произ- 32 | ведения "старого" направления на коэф. 33 | betta , который находится из условия сопря- 34 | жения векторов "старого" и "нового" направ- 35 | ления.Далее делается шаг по вневь найденному 36 | направлению так ,чтобы новая точка была 37 | "лучшей" в данном направлении. Критерий 38 | окончания тот же. 39 | -------------------------------------------------------------------------------- /Math/Optimization/LABA2.TXT: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | СРАВНИТЕЛЬНЫЙ АНАЛИЗ МЕТОДОВ 5 | 6 | 7 | По количеству итеpаций и по скорости выполнения 8 | наиболее эффективным является метод сопряженного 9 | градиента. Для квадратичной функции этот метод 10 | всего за две (три) итерации нашел минимум. 11 | 12 | Однако эти дваметода достаточно трудоемки (по 13 | сравнению с методами нулевого порядка) , тк 14 | требуют знание первых частных производных. 15 | -------------------------------------------------------------------------------- /Math/Optimization/OPTIM.TXT: -------------------------------------------------------------------------------- 1 | ─ SU.PASCAL.MODULA.ADA (2:5021/22) ───────────────────── SU.PASCAL.MODULA.ADA ─ 2 | From : Dmitry S. Wawer 2:50/325.52 28 Jan 97 13:06:32 3 | To : Sergey Ermak 29 Jan 97 13:06:55 4 | Subj : метод наискоpейшего (гpадиентного) спуска 5 | ─────────────────────────────────────────────────────────────────────────────── 6 | Я приветствую Sergey! 7 | 8 | Чет Янв 23 1997 20:14, Alexander Shursha wrote to Sergey Ermak: 9 | 10 | SE>> Есть у кого-нибудь исходники сабжа? 11 | SE>> Диплом в таpтаpаpы летит, не дайте погибнуть. 12 | 13 | Завалялась тут парочка - сопряженного градиента и наискорейшего спуска. 14 | Разберешься значит твои. 15 | 16 | Странно - диплом а в нем такие методы :) это третий курс лаба. 17 | 18 | 19 | Всех благ. 20 | Dima01 21 | 22 | --- GoldED 2.42.A0701+ 23 | * Origin: Hу вы, блин, даете. (2:50/325.52) 24 | 25 | -------------------------------------------------------------------------------- /Math/REVERSE_NUM.PAS: -------------------------------------------------------------------------------- 1 | program reverse; 2 | Var 3 | X, Y: Integer; 4 | 5 | begin 6 | write('Enter integer number: '); readln(X); 7 | Y := 0; 8 | While X > 0 do 9 | begin 10 | Y := (Y * 10) + (X mod 10); 11 | X := X div 10; 12 | end; 13 | writeln(Y); 14 | end. -------------------------------------------------------------------------------- /Math/ROOTS.PAS: -------------------------------------------------------------------------------- 1 | program roots; 2 | uses 3 | crt; 4 | var 5 | a,b,c:real; 6 | procedure test(a,b,c:real); 7 | var 8 | d,x1,x2:real; 9 | begin 10 | if a=0 then 11 | writeln('NO ROOTS'); 12 | d:=sqr(b)-4*a*c; 13 | if d>0 then 14 | begin 15 | x1:=(-b+sqrt(d))/(2*a); 16 | x2:=(-b-sqrt(d))/(2*a); 17 | writeln('x1=',x1:2:2); 18 | writeln('x2=',x2:2:2); 19 | end 20 | else 21 | if d<0 then 22 | write('D<0 than NO ROOTS') 23 | else 24 | write('x1=x2=',-b/(2*a)); 25 | end; 26 | begin 27 | clrscr; 28 | write('Enter a: '); 29 | readln(a); 30 | write('Enter b: '); 31 | readln(b); 32 | write('Enter c: '); 33 | readln(c); 34 | test(a,b,c); 35 | readln; 36 | end. 37 | -------------------------------------------------------------------------------- /Math/Statistics/NORMRAND.PAS: -------------------------------------------------------------------------------- 1 | { Распределение по нормальному закону } 2 | 3 | function NormRand (Mx, S : Real) : Real; 4 | { Mx - мат.ожидание, S - среднеквадр.отклонение } 5 | var 6 | A,B,R,SQ : Real; 7 | begin 8 | repeat 9 | A := 2 * Random - 1; 10 | B := 2 * Random - 1; 11 | R := Sqr(A) + Sqr(B) 12 | until (R < 1); 13 | SQ := Sqrt(-2 * Ln(R) / R); 14 | NormRand := Mx + S * A * SQ 15 | end; 16 | 17 | -------------------------------------------------------------------------------- /Math/Statistics/NRAND.TXT: -------------------------------------------------------------------------------- 1 | Normal random number generators, by J. W. Rider 2 | 3 | The NRAND.ARC file contains code for two different Turbo Pascal 4 | units. One (NRAND0.PAS) contains a Pascal implementation of 5 | algorithms that can be found in the November 1988 issue of 6 | Communications of the ACM. The other (NRAND1.PAS) contains the 7 | "conventional" methods of generating the same random variates. 8 | 9 | In the process of testing NRAND0, I discovered that the 10 | algorithms are extremely sensitive to the use of the 8087 numeric 11 | coprocessor. I was surprised to discover that the conventional 12 | methods worked BETTER than the advertised "fast" algorithms from 13 | CACM, but only when the 8087 was used. When the floating point 14 | processing was done in software, the CACM algorithms performed 15 | significantly better. 16 | 17 | If you use hardware floating point, use NRAND1 to generate your 18 | normal random variates. (A 2:1 speed advantage over NRAND0.) 19 | 20 | If you use software floating point, with or without the Borland 21 | emulation package, use NRAND0. (A 2.3:1 speed advantage over 22 | NRAND1.) 23 | 24 | If you have a choice, use hardware floating point (NRAND1). (A 25 | better than 5:1 speed advantage over NRAND0 with software 26 | processing.) 27 | 28 | Both units have identical interfaces. 29 | 30 | In the interest of portability, both units use the SYSTEM random 31 | function to generate uniformly distributed random variates. This 32 | could easily be changed to incorporate the RAND unit, which can 33 | be found in RANDOM.ARC, BPROGA DL2. 34 | 35 | Copyright 1988, by J. W. Rider. -------------------------------------------------------------------------------- /Math/Statistics/NRAND1.PAS: -------------------------------------------------------------------------------- 1 | { DO NOT USE THIS UNIT IF YOU DON'T USE HARDWARE FLOATING POINT. 2 | For software floating point, use NRAND0.PAS. With hardware 3 | floating point, NRAND0 takes twice as long as NRAND1. } 4 | 5 | {$N+,E-} 6 | unit nrand1; 7 | { conventional implementations of exponential, cauchy and normal 8 | random variate generators } 9 | { Copyright 1988, by J. W. Rider } 10 | 11 | { Since the normal random generator doesn't use either XRANDOM or 12 | CRANDOM, they could be eliminated from both the interface and 13 | the implementation. } 14 | 15 | { Many of the notes that I've included in NRAND0.PAS apply here 16 | also. } 17 | 18 | interface 19 | 20 | function xrandom:real; 21 | { XRANDOM returns an exponentially distributed random variate 22 | with unit mean and variance. To get a variate with mean M and 23 | standard deviation S, use S*XRANDOM+M. } 24 | 25 | function crandom(u:real):real; 26 | { CRANDOM returns a cauchy distributed random variate which don't 27 | have means or variances in the usual sense. The probability 28 | density function is f(x)=1/(pi*(1+sqr(x))). The probability 29 | distribution function is F(x)=0.5-arctan(x)/pi. Obviously, the 30 | median value returned is 0. The "u:real" argument is a holdover 31 | from the A&D implementation in NRAND0.PAS. The normal calling 32 | sequence would be "crandom(random)". } 33 | 34 | function nrandom:real; 35 | { NRANDOM returns a normal or gaussian distributed random variate 36 | with zero mean and unit variance. To get a variate with mean M 37 | and standard deviation S, use S*NRANDOM+M. } 38 | 39 | implementation 40 | var naf: boolean; nay: real; 41 | 42 | function xrandom:real; 43 | var u:real; 44 | begin repeat; u:=random; until u>0; {generally, only one cycle executed} 45 | xrandom:=-ln(u); end; 46 | 47 | function crandom(u:real):real; 48 | var t:real; 49 | begin if (u=0) or (u=1) then begin repeat; 50 | u:=random; until (u>0) and (u<1); end; {generally, never executed} 51 | t:=(u-0.5)*pi; crandom:=sin(t)/cos(t); end; 52 | 53 | function nrandom:real; 54 | var u1,u2:real; 55 | begin naf:=not naf; if naf then nrandom:=nay 56 | else begin repeat; u1:=random; until u1>0; 57 | u1:=sqrt(-2*ln(u1)); u2:=random*pi*2; 58 | nay:=u1*cos(u2); nrandom:=u1*sin(u2); end; end; 59 | 60 | begin naf:=true; end. 61 |  -------------------------------------------------------------------------------- /Math/chebyshev_polinom.pas: -------------------------------------------------------------------------------- 1 | { T0(x)=1, T1(x)=x, Tk(x)=2*x*Tk-1(x)-Tk-2(x) } 2 | 3 | function Chebyshev (x: single; k: integer): single; 4 | var 5 | y: single; 6 | begin 7 | if k = 0 then Chebyshev := 1.0 8 | else 9 | if k = 1 then Chebyshev := x 10 | else 11 | begin 12 | y := 2.0 * x * Chebyshev (x, k-1) - Chebyshev (x, k-2); 13 | Chebyshev := y; 14 | end; 15 | end; 16 | 17 | begin 18 | writeln (Chebyshev (2.0, 3) : 10 : 3); 19 | readln; 20 | end. 21 | -------------------------------------------------------------------------------- /Math/frac.pas: -------------------------------------------------------------------------------- 1 | { Исходное число A(S) умножить на R по правилам S-арифметики. Целая часть 2 | полученного числа представляет собой цифру b-1 числа А(R) . Затем, отбросив 3 | целую часть, умножить дробную часть на R . При этом получается число, целая 4 | часть которого есть цифра b-2 . Повторять процесс умножения l раз, пока не будут 5 | найдены все l цифр числа A(R). } 6 | 7 | const 8 | N = 0.12345678; 9 | MaxP = 5; 10 | epsMaxP = 1e-5; {требуемая точность} 11 | Base = 5; {основание системы} 12 | 13 | var 14 | i: integer; 15 | r, {основание в степени -i } 16 | t, {основание в степени i (степень наращивается в цикле умножением на основание)} 17 | Num, {исходное дробное число} 18 | coef, {коэффициент перед r, который мы вычисляем для каждого слагаемого} 19 | outn: single; {приближённая сумма, должна быть с точностью до MaxP знаков} 20 | 21 | begin 22 | Num := N; 23 | writeln (Num:10:5); 24 | 25 | outn := 0.0; 26 | 27 | t := 1.0; 28 | for i := 1 to MaxP do 29 | begin 30 | t := t * Base; 31 | r := 1.0 / t; {r = base^(-i)} 32 | 33 | Num := Num * Base; {умножаем дробную часть на основание} 34 | coef := Trunc(Num); {Целая часть числа есть коэффициент} 35 | Num := Num - coef; {отбрасываем целую часть} 36 | 37 | outn := outn + coef * r; 38 | 39 | write (coef:4:0); 40 | end; 41 | 42 | writeln; 43 | writeln (outn:10:6); 44 | end. 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Turbo Pascal Archive was created from various sources among them Russian SWAG (Pascal) collection and some portion contributed by me. 2 | 3 | This archive aims educational purposes and mostly suited for students learning Pascal language. 4 | 5 | # Contents 6 | 7 | * Beginners: basic usage of arrays, records, strings; 8 | * Data Structures: many sources of students for work with arrays, linked lists, trees, hashes; sorting/merge algorithms; 9 | * Math: expression parser; various math subroutines on calculus, plane geometry, discrete math, statistics, optimization; 10 | * Lib: various general purpose units like manipulations with bits, string handling, error recovery, cyrillic character translation functions; 11 | * User Interface: basic usage of unit Crt and advanced usage with library Turbo Vision; 12 | * Compression: LZW compression tool; 13 | * Translators: Turbo Pascal to C language translator; 14 | * Files: source code of popular DOS Navigator file manager; unit for support of long file names under Windows 9x. 15 | * Graphics: loading/saving PCS, BMP; displaying fractals; 16 | * and others 17 | 18 | # Notes 19 | 20 | This repository contains too a small number of files with Object Pascal syntax (mostly with usage of one-line comments). 21 | 22 | ## Encoding 23 | 24 | Turbo/Borland Pascal uses ASCII CP437 encoding or its derivations, like cyrillic CP866. 25 | 26 | The files in this online repository were converted to UTF-8 encoding in order to preserve readability by everyone. If you want read and run files with cyrillic inside, you may need to convert them back to CP866 (for example, by GnuWin32 iconv). For the rest of files the back conversion process is useless. -------------------------------------------------------------------------------- /Sound/OCTAVE.PAS: -------------------------------------------------------------------------------- 1 | 2 | uses CRT; 3 | var x,y:real; 4 | a,b,c,d,i:integer; 5 | begin 6 | b:=1; 7 | x:=1; 8 | write('Enter number of octave (1..9): '); readln(a); 9 | write('Enter duration (ms): '); readln(d); 10 | for i:=0 to a do b:=2*b; 11 | for i:=1 to 12 do 12 | begin 13 | y:=16.3516075*b*x; 14 | writeln('Frequency: ',y:8:2,' Hz'); 15 | sound(trunc(y),d); 16 | x:=1.059464*x; 17 | end; 18 | end. 19 | -------------------------------------------------------------------------------- /Translators/TPTC/ATOI.INC: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | * converts ascii string to an integer value 4 | * (tp3 dies on leading spaces but likes trailing. 5 | * tp4 likes leading spaces but dies on trailing!!) 6 | * 7 | *) 8 | 9 | function atol (asc: anystring): longint; 10 | var 11 | i: integer; 12 | value: longint; 13 | num: anystring; 14 | 15 | begin 16 | num := ''; 17 | for i := 1 to length(asc) do 18 | if ((asc[i] >= '0') and (asc[i] <= 'F')) or (asc[i] = '$') then 19 | num := num + asc[i]; 20 | 21 | if length(num) = 0 then 22 | value := 0 23 | else 24 | val(num, value, i); 25 | 26 | atol := value; 27 | end; 28 | 29 | 30 | function atoi (asc: anystring): integer; 31 | begin 32 | atoi := integer(atol(asc)); 33 | end; 34 | 35 | function atow (asc: anystring): word; 36 | begin 37 | atow := word(atol(asc) and $FFFF); 38 | end; 39 | 40 | function htoi (asc: anystring): word; 41 | begin 42 | if copy(asc,1,2) = '0x' then 43 | asc := '$' + copy(asc,3,99); 44 | htoi := word(atol(asc) and $FFFF); 45 | end; 46 | 47 | 48 | -------------------------------------------------------------------------------- /Translators/TPTC/CRT.UNS: -------------------------------------------------------------------------------- 1 | NOSOUND 2 | nosound 3 | 2 8 0 0 0 0 4 | SOUND 5 | sound 6 | 2 8 0 0 1 0 7 | DELAY 8 | delay 9 | 2 8 0 0 1 0 10 | NORMVIDEO 11 | normvideo 12 | 2 8 0 0 0 0 13 | HIGHVIDEO 14 | highvideo 15 | 2 8 0 0 0 0 16 | LOWVIDEO 17 | lowvideo 18 | 2 8 0 0 0 0 19 | TEXTBACKGROUND 20 | textbackground 21 | 2 8 0 0 1 0 22 | TEXTCOLOR 23 | textcolor 24 | 2 8 0 0 1 0 25 | DELLINE 26 | delline 27 | 2 8 0 0 0 0 28 | INSLINE 29 | insline 30 | 2 8 0 0 0 0 31 | CLREOL 32 | clreol 33 | 2 8 0 0 0 0 34 | CLRSCR 35 | clrscr 36 | 2 8 0 0 0 0 37 | WHEREY 38 | wherey 39 | 2 0 0 0 0 0 40 | WHEREX 41 | wherex 42 | 2 0 0 0 0 0 43 | GOTOXY 44 | gotoxy 45 | 2 8 0 0 2 0 46 | WINDOW 47 | window 48 | 2 8 0 0 4 0 49 | TEXTMODE 50 | textmode 51 | 2 8 0 0 1 0 52 | READKEY 53 | getch 54 | 2 4 0 0 0 0 55 | KEYPRESSED 56 | kbhit 57 | 2 7 0 0 0 0 58 | ASSIGNCRT 59 | assigncrt 60 | 2 8 0 0 1 1 61 | WINDMAX 62 | windmax 63 | 0 0 0 0 -1 0 64 | WINDMIN 65 | windmin 66 | 0 0 0 0 -1 0 67 | TEXTATTR 68 | textattr 69 | 0 0 0 255 -1 0 70 | LASTMODE 71 | lastmode 72 | 0 0 0 0 -1 0 73 | CHECKSNOW 74 | checksnow 75 | 0 7 0 1 -1 0 76 | DIRECTVIDEO 77 | directvideo 78 | 0 7 0 1 -1 0 79 | CHECKEOF 80 | checkeof 81 | 0 7 0 1 -1 0 82 | CHECKBREAK 83 | checkbreak 84 | 0 7 0 1 -1 0 85 | BLINK 86 | Blink 87 | 1 0 0 128 -1 0 88 | WHITE 89 | WHITE 90 | 1 0 0 15 -1 0 91 | YELLOW 92 | YELLOW 93 | 1 0 0 14 -1 0 94 | LIGHTMAGENTA 95 | LIGHTMAGENTA 96 | 1 0 0 13 -1 0 97 | LIGHTRED 98 | LIGHTRED 99 | 1 0 0 12 -1 0 100 | LIGHTCYAN 101 | LIGHTCYAN 102 | 1 0 0 11 -1 0 103 | LIGHTGREEN 104 | LIGHTGREEN 105 | 1 0 0 10 -1 0 106 | LIGHTBLUE 107 | LIGHTBLUE 108 | 1 0 0 9 -1 0 109 | DARKGRAY 110 | DARKGRAY 111 | 1 0 0 8 -1 0 112 | LIGHTGRAY 113 | LIGHTGRAY 114 | 1 0 0 7 -1 0 115 | BROWN 116 | BROWN 117 | 1 0 0 6 -1 0 118 | MAGENTA 119 | MAGENTA 120 | 1 0 0 5 -1 0 121 | RED 122 | RED 123 | 1 0 0 4 -1 0 124 | CYAN 125 | CYAN 126 | 1 0 0 3 -1 0 127 | GREEN 128 | GREEN 129 | 1 0 0 2 -1 0 130 | BLUE 131 | BLUE 132 | 1 0 0 1 -1 0 133 | BLACK 134 | BLACK 135 | 1 0 0 0 -1 0 136 | C80 137 | C80 138 | 1 0 0 256 -1 0 139 | C40 140 | C40 141 | 1 0 0 256 -1 0 142 | FONT8X8 143 | Font8x8 144 | 1 0 0 256 -1 0 145 | MONO 146 | Mono 147 | 1 0 0 7 -1 0 148 | CO80 149 | CO80 150 | 1 0 0 3 -1 0 151 | BW80 152 | BW80 153 | 1 0 0 2 -1 0 154 | CO40 155 | CO40 156 | 1 0 0 1 -1 0 157 | BW40 158 | BW40 159 | 1 0 0 0 -1 0 160 | -------------------------------------------------------------------------------- /Translators/TPTC/FTOA.INC: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | * convert floating to ascii 4 | * 5 | *) 6 | 7 | function ftoa(f: real; width,dec: integer): anystring; 8 | var 9 | buf: anystring; 10 | begin 11 | str(f:width:dec,buf); 12 | ftoa := buf; 13 | end; 14 | 15 | 16 |  -------------------------------------------------------------------------------- /Translators/TPTC/GETENV.INC: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | * get the value of an environment variable 4 | * 5 | * (C) 1987 Samuel H. Smith, 14-Dec-87 (rev. 27-Jan-88) 6 | * 7 | * example: path := get_environment_var('PATH='); 8 | * 9 | *) 10 | 11 | function get_environment_var(id: string): string; 12 | var 13 | envseg: integer; 14 | i: integer; 15 | env: string; 16 | 17 | begin 18 | envseg := memw[PrefixSeg:$2c]; 19 | i := 0; 20 | 21 | repeat 22 | env := ''; 23 | while mem[envseg:i] <> 0 do 24 | begin 25 | env := env + chr(mem[envseg:i]); 26 | i := i + 1; 27 | end; 28 | 29 | if copy(env,1,length(id)) = id then 30 | begin 31 | get_environment_var := copy(env,length(id)+1,255); 32 | exit; 33 | end; 34 | 35 | i := i + 1; 36 | until mem[envseg:i] = 0; 37 | 38 | (* not found *) 39 | get_environment_var := ''; 40 | end; 41 | 42 | -------------------------------------------------------------------------------- /Translators/TPTC/ITOA.INC: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | * return the string equivelant of an integer value 4 | * 5 | *) 6 | 7 | function itoa (int: integer): string; 8 | var 9 | tstr: string; 10 | begin 11 | str(int, tstr); 12 | itoa := tstr; 13 | end; 14 | 15 | function ltoa (int: longint): string; 16 | var 17 | tstr: string; 18 | begin 19 | str(int, tstr); 20 | ltoa := tstr; 21 | end; 22 | 23 | 24 | -------------------------------------------------------------------------------- /Translators/TPTC/KEYPRESS.INC: -------------------------------------------------------------------------------- 1 | 2 | (* -------------------------------------------------------- *) 3 | function ReadKey: Char; 4 | var 5 | reg: registers; 6 | begin 7 | reg.ax := $0700; {direct console input} 8 | msdos(reg); 9 | ReadKey := chr(reg.al); 10 | end; 11 | 12 | 13 | (* -------------------------------------------------------- *) 14 | function KeyPressed: Boolean; 15 | var 16 | reg: registers; 17 | begin 18 | reg.ax := $0b00; {ConInputStatus} 19 | msdos(reg); 20 | KeyPressed := (reg.al = $FF); 21 | end; 22 | 23 | -------------------------------------------------------------------------------- /Translators/TPTC/LJUST.INC: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | * ljust - macro for left justified strings in writeln format 4 | * 5 | *) 6 | 7 | function ljust(s: string; w: integer): string; 8 | begin 9 | repeat 10 | s := s + ' '; 11 | until length(s) >= w; 12 | 13 | ljust := s; 14 | end; 15 | 16 | -------------------------------------------------------------------------------- /Translators/TPTC/STOUPPER.INC: -------------------------------------------------------------------------------- 1 | 2 | (*-------------------------------------------------------- 3 | * map string to upper case (tpas 4.0) 4 | *) 5 | 6 | {$F+} procedure stoupper(var st: string); {$F-} 7 | begin 8 | 9 | Inline( 10 | $C4/$7E/$06/ { les di,[bp]6 ;es:di -> st[0]} 11 | $26/ { es:} 12 | $8A/$0D/ { mov cl,[di] ;cl = length} 13 | $FE/$C1/ { inc cl} 14 | 15 | {next:} 16 | $47/ { inc di} 17 | $FE/$C9/ { dec cl} 18 | $74/$12/ { jz ends} 19 | 20 | $26/ { es:} 21 | $8A/$05/ { mov al,[di]} 22 | $3C/$61/ { cmp al,'a'} 23 | $72/$F4/ { jb next} 24 | $3C/$7A/ { cmp al,'z'} 25 | $77/$F0/ { ja next} 26 | 27 | $2C/$20/ { sub al,' '} 28 | $26/ { es:} 29 | $88/$05/ { mov [di],al} 30 | $EB/$E9); { jmp next} 31 | 32 | {ends:} 33 | end; 34 | 35 | -------------------------------------------------------------------------------- /Translators/TPTC/TPTCSYS.UNS: -------------------------------------------------------------------------------- 1 | INPUT 2 | input 3 | 0 6 0 0 -1 0 4 | OUTPUT 5 | output 6 | 0 6 0 0 -1 0 7 | CON 8 | con 9 | 0 6 0 0 -1 0 10 | LST 11 | lst 12 | 0 6 0 0 -1 0 13 | INTR 14 | intr 15 | 2 8 0 0 2 2 16 | MSDOS 17 | msdos 18 | 2 8 0 0 1 1 19 | FSCANV 20 | fscanv 21 | 2 0 0 0 2 1 22 | CPOS 23 | cpos 24 | 2 0 0 0 2 0 25 | SPOS 26 | spos 27 | 2 0 0 0 2 0 28 | SBLD 29 | sbld 30 | 2 8 0 0 2 0 31 | CTOS 32 | ctos 33 | 2 3 0 0 1 0 34 | SCAT 35 | scat 36 | 2 3 0 0 1 0 37 | INSET 38 | inset 39 | 2 7 0 0 2 0 40 | SETOF 41 | setof 42 | 2 5 0 0 1 0 43 | SETREC 44 | setrec 45 | 0 5 0 0 -1 0 46 | DEC 47 | dec 48 | 2 8 0 0 1 0 49 | INC 50 | inc 51 | 2 8 0 0 1 0 52 | LENGTH 53 | strlen 54 | 2 0 0 0 1 0 55 | UPCASE 56 | toupper 57 | 2 4 0 0 1 0 58 | CLOSE 59 | fclose 60 | 2 8 0 0 1 0 61 | FLUSH 62 | fflush 63 | 2 8 0 0 1 0 64 | EOF 65 | feof 66 | 2 7 0 0 1 0 67 | FILLCHAR 68 | fillchar 69 | 2 8 0 0 3 1 70 | MOVE 71 | move 72 | 2 8 0 0 3 3 73 | VAL 74 | val 75 | 2 8 0 0 3 6 76 | COPY 77 | copy 78 | 2 3 0 0 3 0 79 | DELETE 80 | delete 81 | 2 8 0 0 3 0 82 | PARAMSTR 83 | paramstr 84 | 2 3 0 0 1 0 85 | PARAMCOUNT 86 | paramcount 87 | 0 0 0 32767 -1 0 88 | SEEKEOF 89 | seekeof 90 | 2 7 0 0 1 0 91 | SEEK 92 | seek 93 | 2 8 0 0 2 0 94 | SETTEXTBUF 95 | settextbuf 96 | 2 8 0 0 3 2 97 | APPEND 98 | append 99 | 2 8 0 0 1 1 100 | REWRITE 101 | rewrite 102 | 2 8 0 0 1 1 103 | RESET 104 | reset 105 | 2 8 0 0 1 1 106 | ASSIGN 107 | assign 108 | 2 8 0 0 2 0 109 | RELEASE 110 | release 111 | 2 8 0 0 1 1 112 | MARK 113 | mark 114 | 2 8 0 0 1 1 115 | DISPOSE 116 | dispose 117 | 2 8 0 0 1 1 118 | MAXAVAIL 119 | maxavail 120 | 2 1 0 0 0 0 121 | MEMAVAIL 122 | memavail 123 | 2 1 0 0 0 0 124 | LO 125 | lo 126 | 2 0 0 0 1 0 127 | HI 128 | hi 129 | 2 0 0 0 1 0 130 | ORD 131 | ord 132 | 2 0 0 0 1 0 133 | SUCC 134 | succ 135 | 2 0 0 0 1 0 136 | PRED 137 | pred 138 | 2 0 0 0 1 0 139 | INT 140 | int 141 | 2 2 0 0 1 0 142 | ROUND 143 | ceil 144 | 2 2 0 0 1 0 145 | TRUNC 146 | trunc 147 | 2 1 0 0 1 0 148 | SQRT 149 | sqrt 150 | 2 2 0 0 1 0 151 | SQR 152 | sqr 153 | 2 2 0 0 1 0 154 | TAN 155 | tan 156 | 2 2 0 0 1 0 157 | COS 158 | cos 159 | 2 2 0 0 1 0 160 | SIN 161 | sin 162 | 2 2 0 0 1 0 163 | -------------------------------------------------------------------------------- /User Interface/DOS Fonts/HEBEGA.CPI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/HEBEGA.CPI -------------------------------------------------------------------------------- /User Interface/DOS Fonts/HEB_8X16.FNT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/HEB_8X16.FNT -------------------------------------------------------------------------------- /User Interface/DOS Fonts/HEB_8X16.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/HEB_8X16.OBJ -------------------------------------------------------------------------------- /User Interface/DOS Fonts/HEB_8X8.FNT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/HEB_8X8.FNT -------------------------------------------------------------------------------- /User Interface/DOS Fonts/RUS.PAS: -------------------------------------------------------------------------------- 1 | Unit Rus; 2 | 3 | interface 4 | 5 | implementation 6 | 7 | Procedure SetUpFont(p : pointer);far;Assembler; 8 | Asm 9 | Mov Ax,1110h 10 | Mov Bx,1000h 11 | Mov Cx,100h 12 | Xor Dx,Dx 13 | Push Bp 14 | Les Bp,P 15 | Int 10h 16 | Pop Bp 17 | End; 18 | 19 | var 20 | BakExitProc : pointer; 21 | 22 | Procedure ResetFonts;far; 23 | begin 24 | Asm 25 | Mov Ax,1104h 26 | Xor Bx,Bx 27 | Int 10h 28 | End; 29 | ExitProc:=BakExitProc; 30 | end; 31 | 32 | 33 | {$L rus_8x16.obj} 34 | procedure font;external; 35 | 36 | begin 37 | BakExitProc:=ExitProc; 38 | ExitProc:=@ResetFonts; 39 | setupfont(@font); 40 | end. 41 | -------------------------------------------------------------------------------- /User Interface/DOS Fonts/RUS_8X16.FNT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/RUS_8X16.FNT -------------------------------------------------------------------------------- /User Interface/DOS Fonts/RUS_8X16.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/RUS_8X16.OBJ -------------------------------------------------------------------------------- /User Interface/DOS Fonts/SCRIBBLE.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/DOS Fonts/SCRIBBLE.OBJ -------------------------------------------------------------------------------- /User Interface/DOS Fonts/TESTRUS.PAS: -------------------------------------------------------------------------------- 1 | Uses rus; 2 | begin 3 | writeln('АБВГД'); 4 | ReadLn; 5 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/DESK.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/DESK.PAS -------------------------------------------------------------------------------- /User Interface/Turbo Vision/DIALL.PAS: -------------------------------------------------------------------------------- 1 | Program Diall; 2 | 3 | uses App, Objects, Drivers, Views, Menus, Dialogs, MsgBox, 4 | Crt, GrowView; 5 | const 6 | cmDialog = 1001; 7 | type 8 | PMyApp = ^TMyApp; 9 | TMyApp = object(TApplication) 10 | procedure MakeDialog; 11 | procedure HandleEvent(var Event: TEvent); virtual; 12 | procedure InitStatusLine; virtual; 13 | end; 14 | 15 | procedure TMyApp.HandleEvent(var Event: TEvent); 16 | begin 17 | TApplication.HandleEvent(Event); 18 | if Event.What = evCommand then 19 | begin 20 | case Event.Command of 21 | cmDialog:begin 22 | MakeDialog; 23 | end; 24 | else 25 | Exit; 26 | end; 27 | ClearEvent(Event); 28 | end; 29 | end; 30 | 31 | procedure TMyApp.InitStatusLine; 32 | var 33 | R: TRect; 34 | begin 35 | GetExtent(R); 36 | R.A.Y := R.B.Y-1; 37 | StatusLine := New(PStatusLine, Init(R, 38 | NewStatusDef(0, $FFFF, 39 | NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, 40 | NewStatusKey('Dialog - ~F5~', kbF5, cmDialog, 41 | nil)), 42 | nil))); 43 | end; 44 | 45 | procedure TMyApp.MakeDialog; 46 | const max=55; 47 | var 48 | R:TRect; 49 | Dlg: TDialog; 50 | MyBar: PGrowView; 51 | i:integer; 52 | L: longint; 53 | ps: string; 54 | 55 | begin 56 | R.Assign( 24, 9, 60, 14); 57 | Dlg.Init (R, 'Progress bar'); 58 | Dlg.Flags := Dlg.Flags and not wfClose; 59 | R.assign( 2, 2, 34, 3); 60 | MyBar:=New( PGrowView, Init(r, max)); 61 | Dlg.Insert(MyBar); 62 | Desktop^.Insert(@Dlg); 63 | for i:=1 to max do 64 | begin 65 | Delay(1500); 66 | MyBar^.Update(i); 67 | R.Assign(2,3,14,4); 68 | Dlg.Insert(New( PStaticText, Init(R, 'filename.ext'))); 69 | L:=MyBar^.Percent(i,max); 70 | formatstr(ps,'%3d%%',L); 71 | R.Assign(30,3,34,4); 72 | Dlg.Insert(New( PStaticText, 73 | Init(R, ps))); 74 | end; 75 | Dlg.Done; 76 | end; 77 | 78 | var 79 | MyAppWorld: TMyApp; 80 | begin 81 | MyAppWorld.Init; 82 | MyAppWorld.Run; 83 | MyAppWorld.Done; 84 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/DIRLIST.PAS: -------------------------------------------------------------------------------- 1 | {$X+} 2 | uses 3 | Drivers,Objects,Views,Dialogs,App,MsgBox,Strings,LFN,NatLFN; 4 | {--} 5 | Type 6 | PDirCollection=^TDirCollection; 7 | TDirCollection=object(TStringCollection) 8 | Constructor Init(ALimit, ADelta: Integer); 9 | end; 10 | 11 | PMyListBox=^TMyListBox; 12 | TMyListBox=object(TListBox) 13 | C: PDirCollection; 14 | procedure HandleEvent(var Event: TEvent); virtual; 15 | end; 16 | 17 | PMyDlg = ^TMyDlg; 18 | TMyDlg = object(TDialog) 19 | M: PMyListBox; 20 | constructor Init(Bounds: TRect; ATitle: TTitleStr); 21 | end; 22 | {--} 23 | PApp = ^TApp; 24 | TApp = object(TApplication) 25 | constructor Init; 26 | end; 27 | 28 | Constructor TDirCollection.Init; 29 | var 30 | S: PString; 31 | ss: string; 32 | Info: TLFNSearchRec; 33 | e: word; 34 | begin 35 | Inherited Init(ALimit, ADelta); 36 | e:=LFNFindFirst('*.',$10, Info); 37 | While e=0 do 38 | begin 39 | ss:= strpas(@(Info.Name)); 40 | if ss<>'.' then Insert(NewStr(ss)); 41 | e:=LFNFindNext(Info); 42 | End; 43 | end; 44 | 45 | procedure TMyListBox.HandleEvent(var Event: TEvent); 46 | var 47 | S: String; 48 | begin 49 | if ((Event.What=evMouseDown) and Event.Double) OR 50 | ((Event.What=evKeyDown) and (Event.KeyCode=kbEnter)) then 51 | begin 52 | S :=PString(List^.At(Focused))^; 53 | if s<>'.' then 54 | begin 55 | chdir(s); 56 | NewList(New(PDirCollection,Init(20,10))); 57 | DrawView; 58 | end; 59 | ClearEvent(Event); 60 | end; 61 | TListBox.HandleEvent(Event); 62 | end; 63 | {--} 64 | constructor TMyDlg.Init(Bounds: TRect; ATitle: TTitleStr); 65 | var 66 | R: TRect; 67 | B: PView; 68 | begin 69 | Inherited Init(Bounds, ATitle); 70 | Options := Options or ofCentered; 71 | R.Assign (24,1,25,10); 72 | B := New(PScrollBar,Init (R)); 73 | Insert(B); 74 | R.Assign (2,1,24,10); 75 | M := New (PMyListBox,Init (R,1,PScrollBar(B))); 76 | Insert(M); 77 | M^.NewList(New(PDirCollection,Init(20,10))) 78 | end; 79 | 80 | constructor TApp.Init; 81 | var 82 | R: TRect; 83 | D: PDialog; 84 | begin 85 | TApplication.Init; 86 | R.Assign (0,0,27,15); 87 | D := New (PMyDlg,Init (R,'Dir list')); 88 | DeskTop^.ExecView (D); 89 | end; 90 | {--} 91 | var 92 | A: TApp; 93 | begin 94 | A.Init; 95 | A.Run; 96 | A.Done; 97 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/EXTRABAR.PAS: -------------------------------------------------------------------------------- 1 | program ExtraMenuBar; 2 | uses Objects, Drivers, Views, Menus, App; 3 | const 4 | cmFileOpen = 100; 5 | cmNewWin = 101; 6 | type 7 | PExtraMenuBar = ^TExtraMenuBar; 8 | TExtraMenuBar = object(TMenuBar) 9 | procedure Draw;virtual; 10 | end; 11 | 12 | TMyApp = object(TApplication) 13 | ExtraMenuBar : PExtraMenuBar; 14 | procedure InitMenuBar; virtual; 15 | end; 16 | procedure TExtraMenuBar.Draw; 17 | const 18 | ProgName : String=' eXtra Bar '; 19 | begin 20 | TMenuBar.Draw; 21 | WriteStr(35,0,ProgName,$0); 22 | end; 23 | 24 | { TMyApp } 25 | procedure TMyApp.InitMenuBar; 26 | var R: TRect; 27 | begin 28 | GetExtent(R); 29 | ExtraMenuBar := New(PExtraMenuBar,Init(R,nil)); 30 | Insert(ExtraMenuBar); 31 | { R.B.Y := R.A.Y + 2; 32 | R.A.Y := 1; 33 | MenuBar := New(PMenuBar, Init(R, NewMenu( 34 | NewSubMenu('~F~ile', hcNoContext, NewMenu( 35 | NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext, 36 | NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext, 37 | NewLine( 38 | NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext, 39 | nil))))), 40 | nil)))); 41 | } 42 | end; 43 | var 44 | MyApp: TMyApp; 45 | begin 46 | MyApp.Init; 47 | MyApp.Run; 48 | MyApp.Done; 49 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/FM.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/FM.PAS -------------------------------------------------------------------------------- /User Interface/Turbo Vision/GROWVIEW.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/GROWVIEW.PAS -------------------------------------------------------------------------------- /User Interface/Turbo Vision/HELPTEST.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/HELPTEST.PAS -------------------------------------------------------------------------------- /User Interface/Turbo Vision/LAYOUT.PAS: -------------------------------------------------------------------------------- 1 | 2 | unit Layout; 3 | interface 4 | uses Objects, MsgBox; 5 | 6 | procedure HandleError( Mess: String ); 7 | procedure Inform( R: TRect; Mess: String; Params: Pointer ); 8 | function Confirm( Mess: String ): Word; 9 | 10 | implementation 11 | 12 | procedure HandleError( Mess: String ); 13 | var C: Word; 14 | begin 15 | C:=MessageBox( Mess, nil, mfError + mfOKButton ) 16 | end; 17 | 18 | procedure Inform( R: TRect; Mess: String; Params: Pointer ); 19 | var C: Word; 20 | begin 21 | C:=MessageBoxRect( R, Mess, Params, mfInformation + mfOKButton ) 22 | end; 23 | 24 | function Confirm( Mess: String ): Word; 25 | var R: TRect; 26 | begin 27 | R.Assign (10,4,60,12); 28 | Confirm:=MessageBoxRect( R, Mess, nil, mfConfirmation + mfOKCancel ) 29 | end; 30 | 31 | end. 32 | -------------------------------------------------------------------------------- /User Interface/Turbo Vision/MATRIX.PAS: -------------------------------------------------------------------------------- 1 | { From : Nick Doodka 2:4641/58.18 24.12.97} 2 | { Subj : Двумерный массив на базе коллекций } 3 | unit Matrix; 4 | 5 | interface 6 | 7 | uses Objects; 8 | 9 | type 10 | PMatrix = ^TMatrix; 11 | TMatrix = object(TCollection) 12 | Column: Integer; 13 | constructor Init(Cols, Rows: Integer); 14 | function Get(X, Y: Integer): PObject; 15 | procedure Put(X, Y: Integer; Item: PObject); 16 | procedure InsCol(Col: Integer); 17 | procedure InsRow(Row: Integer); 18 | procedure DelCol(Col: Integer); 19 | procedure DelRow(Row: Integer); 20 | end; 21 | 22 | implementation 23 | 24 | constructor TMatrix.Init(Cols, Rows: Integer); 25 | begin 26 | inherited Init(Rows, 10); 27 | Column := Cols; 28 | for Rows := 0 to Pred(Rows) do InsRow(0); 29 | end; 30 | 31 | function TMatrix.Get(X, Y: Integer): PObject; 32 | begin 33 | Get := PCollection(At(Y))^.At(X) 34 | end; 35 | 36 | procedure TMatrix.Put(X, Y: Integer; Item: PObject); 37 | var 38 | P: PObject; 39 | begin 40 | P := Get(X, Y); 41 | PCollection(At(Y))^.AtPut(X, Item); 42 | if P <> nil then Dispose(P, Done); 43 | end; 44 | 45 | procedure TMatrix.InsCol(Col: Integer); 46 | 47 | procedure InsertColumn(P: PCollection); far; 48 | begin 49 | P^.AtInsert(Col, nil); 50 | end; 51 | 52 | begin 53 | ForEach(@InsertColumn); 54 | Column := PCollection(At(0))^.Count; 55 | end; 56 | 57 | procedure TMatrix.InsRow(Row: Integer); 58 | var 59 | C: PCollection; 60 | begin 61 | C := New(PCollection, Init(Column, 10)); 62 | AtInsert(Row, C); 63 | for Row := 0 to Column - 1 do C^.Insert(nil); 64 | end; 65 | 66 | procedure TMatrix.DelCol(Col: Integer); 67 | 68 | procedure FreeColumn(P: PCollection); far; 69 | begin 70 | P^.AtFree(Col); 71 | end; 72 | 73 | begin 74 | ForEach(@FreeColumn); 75 | Column := PCollection(At(0))^.Count; 76 | end; 77 | 78 | procedure TMatrix.DelRow(Row: Integer); 79 | begin 80 | AtFree(Row); 81 | end; 82 | 83 | end. 84 | 85 | -------------------------------------------------------------------------------- /User Interface/Turbo Vision/MULSEL.PAS: -------------------------------------------------------------------------------- 1 | 2 | Unit MulSel; 3 | 4 | Interface 5 | uses 6 | Dos,App,Objects,Views,Dialogs,Drivers; 7 | 8 | type 9 | 10 | TByteArray = array[0..$FF-1] of byte; 11 | PByteArray = ^TByteArray; 12 | 13 | PMultiSelListBox = ^TMultiSelListBox; 14 | TMultiSelListBox = object (TListBox) 15 | SelArr : PByteArray; 16 | constructor Init (var Bounds: TRect; AScrollBar: PScrollBar); 17 | destructor Done; virtual; 18 | procedure SelectItem (Item: Integer); virtual; 19 | function IsSelected (Item: Integer): Boolean; virtual; 20 | procedure HandleEvent(var Event: TEvent); virtual; 21 | end; 22 | 23 | Implementation 24 | 25 | constructor TMultiSelListBox.Init; 26 | begin 27 | Inherited Init (Bounds, 2, AScrollBar); 28 | New (SelArr); 29 | if SelArr <> Nil then 30 | FillChar (SelArr^, SizeOf (TByteArray), 0); 31 | end; 32 | 33 | destructor TMultiSelListBox.Done; 34 | begin 35 | if SelArr <> Nil then 36 | Dispose (SelArr); 37 | Inherited Done 38 | end; 39 | 40 | function TMultiSelListBox.IsSelected; 41 | begin 42 | IsSelected := (SelArr^[Item] <> 0) 43 | end; 44 | 45 | procedure TMultiSelListBox.SelectItem; 46 | begin 47 | SelArr^[Item] := SelArr^[Item] xor 1; {switch selection: 1 <-> 0 } 48 | DrawView; 49 | end; 50 | 51 | procedure TMultiSelListBox.HandleEvent; 52 | begin 53 | case Event.What of 54 | 55 | evMouseDown: 56 | begin 57 | if Event.Buttons = mbRightButton then 58 | begin 59 | SelectItem (Focused); 60 | end; 61 | inherited HandleEvent(Event); 62 | ClearEvent(Event); 63 | end; 64 | 65 | evKeyDown: 66 | if Event.CharCode = ' ' then 67 | begin 68 | SelectItem(Focused); 69 | Event.KeyCode := kbDown; 70 | DrawView; 71 | end; 72 | end; 73 | 74 | inherited HandleEvent(Event); 75 | end; 76 | 77 | end. 78 | -------------------------------------------------------------------------------- /User Interface/Turbo Vision/PASSWD.PAS: -------------------------------------------------------------------------------- 1 | {SWAG=OOP.SWG,MARK VAN LEEUWEN,TV Password Unit,PASSWORD,UNIT} 2 | Unit Passwd; 3 | {*************************************************************************** 4 | Written by Mark S. Van Leeuwen. 5 | This Code is Public Domain. 6 | Please Include my Name in any application that uses this code. 7 | ***************************************************************************} 8 | 9 | Interface 10 | 11 | Uses Objects,Dialogs,Views,Drivers; 12 | 13 | Type 14 | PPasswordLine=^TPasswordLine; 15 | TPasswordLine=Object(TInputline) 16 | Data1 :String; 17 | Constructor Init(Var Bounds :TRect; AMaxLen :Integer); 18 | Procedure GetData(Var Rec);Virtual; 19 | Procedure SetData(Var Rec);Virtual; 20 | Procedure HandleEvent(Var Event :TEvent);Virtual; 21 | End; 22 | 23 | Implementation 24 | 25 | {**************** Constructor for the Password Inputline Data **************} 26 | Constructor TPasswordLine.Init(Var Bounds :TRect; AMaxlen :Integer); 27 | Begin 28 | Data1:=''; 29 | TInputline.Init(Bounds,AMaxLen); 30 | End; 31 | {******************* Get Data from Procedure *******************************} 32 | Procedure TPasswordLine.GetData(Var Rec); 33 | Begin 34 | String(Rec):=Data1; 35 | End; 36 | {****************** Set Data to Procedure **********************************} 37 | Procedure TPasswordLine.SetData(Var Rec); 38 | Begin 39 | Data1:=String(Rec); 40 | SelectAll(True); 41 | End; 42 | {******************** Handle Inputline Event *******************************} 43 | Procedure TPasswordLine.HandleEvent(Var Event :TEvent); 44 | Var 45 | C: String[1]; 46 | Begin 47 | With Event Do 48 | If (What = evKeyDown) And (KeyCode = kbEsc) Then 49 | Begin 50 | What := Command; 51 | Command := cmClose; 52 | End; 53 | Case Event.What Of 54 | evKeyDown: 55 | Begin 56 | If(UpCase(Event.CharCode) In ['A'..'Z','0'..'9']) Then 57 | Begin 58 | C:=Event.CharCode; 59 | Data1:=Concat(Data1,C); 60 | Event.CharCode:='*'; 61 | End; 62 | If(Event.KeyCode = kbBack) OR (Event.KeyCode = kbDel) Then 63 | Begin 64 | If(byte(Data1[0]) <> 0)Then Dec(Data1[0]); 65 | Event.KeyCode:=kbBack; 66 | End; 67 | End; 68 | evBroadcast: 69 | Begin 70 | End; 71 | End; 72 | TInputLine.HandleEvent(Event); 73 | End; 74 | End. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/PASSWD2.PAS: -------------------------------------------------------------------------------- 1 | {SWAG=OOP.SWG,MARK VAN LEEUWEN,TV Password Unit,PASSWORD,UNIT} 2 | Unit Passwd2; 3 | {*************************************************************************** 4 | Written by Mark S. Van Leeuwen. 5 | ***************************************************************************} 6 | 7 | Interface 8 | 9 | Uses Objects,Dialogs,Views,Drivers; 10 | 11 | Type 12 | PPasswordLine=^TPasswordLine; 13 | TPasswordLine=Object(TInputline) 14 | Data1 :String; 15 | Constructor Init(Var Bounds :TRect; AMaxLen :Integer); 16 | Procedure GetData(Var Rec);Virtual; 17 | Procedure SetData(Var Rec);Virtual; 18 | Procedure HandleEvent(Var Event :TEvent);Virtual; 19 | End; 20 | 21 | Implementation 22 | 23 | {**************** Constructor for the Password Inputline Data **************} 24 | Constructor TPasswordLine.Init(Var Bounds :TRect; AMaxlen :Integer); 25 | Begin 26 | Data1:=''; 27 | TInputline.Init(Bounds,AMaxLen); 28 | End; 29 | {******************* Get Data from Procedure *******************************} 30 | Procedure TPasswordLine.GetData(Var Rec); 31 | Begin 32 | String(Rec):=Data1; 33 | End; 34 | {****************** Set Data to Procedure **********************************} 35 | Procedure TPasswordLine.SetData(Var Rec); 36 | Begin 37 | Data1:=String(Rec); 38 | SelectAll(True); 39 | End; 40 | {******************** Handle Inputline Event *******************************} 41 | Procedure TPasswordLine.HandleEvent(Var Event :TEvent); 42 | Var 43 | C: char; 44 | Begin 45 | With Event Do 46 | If (What = evKeyDown) And (KeyCode = kbEsc) Then 47 | Begin 48 | What := Command; 49 | Command := cmClose; 50 | End; 51 | Case Event.What Of 52 | evKeyDown: 53 | Begin 54 | If(UpCase(Event.CharCode) In ['A'..'Z','0'..'9']) Then 55 | Begin 56 | C:=Event.CharCode; 57 | Data1 := Data1 + C; 58 | Event.CharCode:='*'; 59 | End; 60 | If(Event.KeyCode = kbBack) OR (Event.KeyCode = kbDel) Then 61 | Begin 62 | If(byte(Data1[0]) <> 0)Then Dec(Data1[0]); 63 | Event.KeyCode:=kbBack; 64 | End; 65 | End; 66 | End; 67 | Inherited HandleEvent(Event); 68 | End; 69 | 70 | End. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/POPUP.PAS: -------------------------------------------------------------------------------- 1 | PROGRAM PopUp; 2 | USES App, Objects, Menus, Drivers, Views; 3 | 4 | TYPE TPopupMenu = OBJECT(TMenuPopup) 5 | DESTRUCTOR Done; VIRTUAL; 6 | END; 7 | PPopupMenu = ^TPopupMenu; 8 | 9 | TTestApp = OBJECT(TApplication) 10 | PROCEDURE HandleEvent(VAR Event : TEvent); VIRTUAL; 11 | FUNCTION MakePopup(where : TPoint) : PPopupMenu; 12 | END; 13 | 14 | DESTRUCTOR TPopupMenu.Done; 15 | BEGIN 16 | IF (Menu <> NIL) THEN DisposeMenu(menu); 17 | INHERITED Done; 18 | END; 19 | 20 | FUNCTION TTestApp.MakePopup(where : TPoint) : PPopupMenu; 21 | VAR R : TRect; 22 | BEGIN 23 | R.Assign(where.x, where.y, where.x+10, where.y); {*} 24 | MakePopup := New(PPopupMenu, Init(R, NewMenu( 25 | NewItem('~N~ew', '', kbNoKey, cmNew, hcNew, 26 | NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen, 27 | NIL))))); 28 | END; 29 | 30 | PROCEDURE TTestApp.HandleEvent(VAR event : TEvent); 31 | VAR MenuChoice : Word; 32 | Popup : PPopupMenu; 33 | BEGIN 34 | IF (Event.what = evMouseDown) AND 35 | (Event.Buttons = mbRightButton) THEN 36 | BEGIN 37 | Popup := MakePopup(event.where); 38 | MenuChoice := ExecView(popup); 39 | { Jetzt Auswahl abarbeiten } 40 | 41 | Dispose(popup, Done); 42 | ClearEvent(event); 43 | END 44 | ELSE INHERITED HandleEvent(event); 45 | END; 46 | 47 | VAR T: TTestApp; 48 | BEGIN 49 | T.Init; 50 | T.Run; 51 | T.Done; 52 | END. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/SETBOX.PAS: -------------------------------------------------------------------------------- 1 | unit setbox; 2 | {ListBox для множественного выбора} 3 | { Отметка элемента пробелом или двойным нажатием кнопки мыши} 4 | {Методы GetData и SetData работают с записью вида} 5 | { record } 6 | { List:PCollection; } 7 | { Selected:Set of 0..255; } 8 | { Проверки на List^.Сount<=255 нет } 9 | interface 10 | uses objects,drivers,views,dialogs; 11 | Type 12 | TSet = set of 0..255; 13 | PSetBox = ^TSetBox; 14 | TSetBox = Object (TListBox) 15 | Selected:TSet; 16 | Procedure HandleEvent(var Event:TEvent);virtual; 17 | Procedure SetData(var Rec);virtual; 18 | Procedure GetData(var Rec);virtual; 19 | Procedure NewList(Alist:PCollection);virtual; 20 | {Do not override this method!! override GetItemText if needed} 21 | function GetText(Item: Integer; MaxLen: Integer): String; virtual; 22 | function GetItemText(Item: Integer; MaxLen: Integer): String; virtual; 23 | Function DataSize:Word;virtual; 24 | end; 25 | implementation 26 | Function TSetBox.DataSize; 27 | begin 28 | DataSize:=SizeOf(List)+SizeOf(Selected); 29 | end; 30 | Procedure TSetBox.GetData(var Rec); 31 | var R:record 32 | List:Pointer; 33 | Selected:TSet 34 | end absolute Rec; 35 | begin 36 | R.List:=List; 37 | R.Selected:=Selected; 38 | end; 39 | Procedure TSetBox.SetData(var Rec); 40 | var R:record 41 | List:Pointer; 42 | Selected:TSet 43 | end absolute Rec; 44 | begin 45 | NewList(R.List); 46 | Selected:=R.Selected; 47 | end; 48 | Procedure TSetBox.NewList(Alist:PCollection); 49 | begin 50 | TListBox.NewList(AList); 51 | Selected:=[]; 52 | end; 53 | function TSetBox.GetItemText(Item: Integer; MaxLen: Integer): String; 54 | begin 55 | GetItemText:=TListBox.GetText(Item,MaxLen); 56 | end; 57 | function TSetBox.GetText(Item: Integer; MaxLen: Integer): String; 58 | var C:Char; 59 | begin 60 | if Item in Selected then C:='' else C:=' '; 61 | GetText:=C+GetItemText(Item,Pred(MaxLen)); 62 | end; 63 | Procedure TSetBox.HandleEvent(var Event:TEvent); 64 | var ChangeSelection:Boolean; 65 | begin 66 | ChangeSelection:= ((Event.What=evKeyDown)and(Event.CharCode=' '))or 67 | ((Event.What=evMouseDown) and Event.Double and MouseInView(Event.Where)); 68 | TListBox.HandleEvent(Event); 69 | if ChangeSelection then 70 | begin 71 | if Focused in Selected then Selected:=Selected - [Focused] else 72 | Selected:=Selected+[Focused]; 73 | DrawView; 74 | end; 75 | end; 76 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/SORTWORD.PAS: -------------------------------------------------------------------------------- 1 | 2 | program Sorting_of_Words; 3 | uses Objects; 4 | var F,FF: text; 5 | PSC: PStringCollection; 6 | str: string[20]; 7 | erc: integer; 8 | i,countline: word; 9 | const Fname='sortword.dat'; 10 | 11 | begin 12 | assign(F, Fname); 13 | {$I-} 14 | reset(F); { Read file with array of words that you want arrange by name } 15 | {$I+} 16 | if IOresult<>0 then 17 | begin 18 | writeln('File ', Fname,' not found'); 19 | halt(1); 20 | end; 21 | countline:=0; 22 | if not EOF(F) then 23 | begin 24 | readln(F,str); 25 | val(str,countline,erc); 26 | if erc>0 then 27 | begin 28 | writeln('First line doesn''t contain number of strings'); 29 | close(F); 30 | halt; 31 | end; 32 | end; 33 | if countline<2 then 34 | begin 35 | close(F); 36 | halt; 37 | end; 38 | PSC := New(PStringCollection, Init( CountLine,0 )); 39 | while not EOF(F) do 40 | begin 41 | readln(F,str); 42 | PSC^.Insert(NewStr(Str)); 43 | end; 44 | 45 | assign(FF, 'sortword.srt'); 46 | rewrite(FF); 47 | for i:=0 to CountLine-1 do 48 | writeln(FF,PString(PSC^.at(i))^); 49 | Close(FF); 50 | Close(F); 51 | 52 | Dispose(PSC); 53 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TESTINP.PAS: -------------------------------------------------------------------------------- 1 | {$N+} 2 | uses Drivers, Objects, Views, Menus, App,Dialogs, 3 | numinput; 4 | 5 | const cmOpenDialog=1500; 6 | type 7 | TTutorApp = object(TApplication) 8 | procedure HandleEvent(var Event: TEvent); virtual; 9 | procedure InitStatusLine; virtual; 10 | procedure Dialog; 11 | end; 12 | var F: word; 13 | S:string; 14 | 15 | procedure TTutorApp.HandleEvent(var Event: TEvent); 16 | var 17 | R: TRect; 18 | begin 19 | inherited HandleEvent(Event); 20 | if Event.What = evCommand then 21 | begin 22 | case Event.Command of 23 | cmOpenDialog: 24 | begin 25 | Dialog; 26 | end; 27 | end; 28 | end; 29 | end; 30 | 31 | procedure TTutorApp.InitStatusLine; 32 | var 33 | R: TRect; 34 | begin 35 | GetExtent(R); 36 | R.A.Y := R.B.Y - 1; 37 | New(StatusLine, Init(R, 38 | NewStatusDef(0, $FFFF, 39 | NewStatusKey('~Alt-X~ Exit', kbAltX, 1, 40 | NewStatusKey('~F3~ OpenDialog', kbF3, cmOpenDialog, 41 | nil)), 42 | nil))); 43 | end; 44 | 45 | procedure TTutorApp.Dialog; 46 | {type 47 | DlgData = record 48 | InputLineData: string[128]; 49 | end;} 50 | var 51 | Dlg : PDialog; 52 | R : TRect; 53 | Control : PView; 54 | ctr:word; 55 | DialogData: string; {DlgData;} 56 | WIL: PWordInputLine; {} 57 | begin 58 | R.Assign(25, 7, 55, 16); 59 | New(Dlg, Init(R, 'Demo Dialog')); 60 | 61 | R.Assign(4,2,26,3); 62 | Control:= New(PStaticText,Init(r,#3'Input number')); 63 | Dlg^.Insert(Control); 64 | 65 | R.Assign(10, 3, 20, 4); 66 | WIL:= New(PWordInputLine, Init(R));{} 67 | Dlg^.Insert(WIL); 68 | 69 | R.Assign(5, 6, 13, 8); 70 | Control := New(PButton, Init(R, 'O~K~', cmOK, bfDefault)); 71 | Dlg^.Insert(Control); 72 | R.Assign(16, 6, 26, 8); 73 | Control := (New(PButton, Init(R, 'Cancel', cmCancel, bfNormal))); 74 | Dlg^.Insert(Control); 75 | 76 | Dlg^.SelectNext(False); 77 | Ctr := DeskTop^.ExecView(Dlg); 78 | if Ctr <> cmCancel then begin 79 | WIL^.GetData(F); 80 | { S:=WIL^.Data^;} 81 | end; 82 | Dispose(Dlg,done); 83 | end; 84 | 85 | 86 | var 87 | TutorApp: TTutorApp; 88 | 89 | begin 90 | TutorApp.Init; 91 | TutorApp.Run; 92 | TutorApp.Done; 93 | writeln(F); 94 | { writeln(S);} 95 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TESTSEL.PAS: -------------------------------------------------------------------------------- 1 | 2 | uses 3 | Objects,Dos, 4 | App,Views,Drivers,Dialogs,Menus,MsgBox, StdDlg,mulsel; 5 | 6 | const 7 | cmDlg=101; 8 | type 9 | PPickWindow = ^TPickWindow; 10 | TPickWindow = object(TDialog) 11 | D: PMultiSelListBox; 12 | constructor Init; 13 | end; 14 | 15 | TPickApp = object(TApplication) 16 | PickWindow: PPickWindow; 17 | procedure HandleEvent(var Event: TEvent); virtual; 18 | procedure InitStatusLine; virtual; 19 | end; 20 | 21 | constructor TPickWindow.Init; 22 | var 23 | R: TRect; 24 | Control: PView; 25 | PS: PScrollBar; 26 | Lis: PStringCollection; 27 | i: byte; 28 | begin 29 | R.Assign(0, 0, 40, 20); 30 | inherited Init(R, 'Pick List Window'); 31 | Options := Options or ofCentered; 32 | 33 | R.Assign(2, 14, 38, 15); 34 | PS:=New(PScrollBar, Init(R)); 35 | Insert(PS); 36 | 37 | R.Assign(2, 2, 38, 14); 38 | D := New (PMultiSelListBox, Init (R, PS)); 39 | 40 | Lis := New (PStringCollection, Init (10,4)); 41 | if Lis <> Nil then 42 | for i := 0 to 9 do 43 | Lis^.Insert (NewStr ('item' + Chr (48 + i))); 44 | 45 | D^.NewList (Lis); 46 | Insert(D); 47 | 48 | R.Assign(15, 16, 25, 18); 49 | Insert(New(PButton, Init(R, '~O~k', cmOk, bfDefault))); 50 | 51 | SelectNext(True); 52 | end; 53 | 54 | procedure TPickApp.InitStatusLine; 55 | var 56 | R: TRect; 57 | begin 58 | GetExtent(R); 59 | R.A.Y := R.B.Y - 1; 60 | New(StatusLine, Init(R, 61 | NewStatusDef(0, $FFFF, 62 | NewStatusKey('~Alt-X~ Exit', kbAltX, 1, 63 | NewStatusKey('~F1~ List dialog', kbF1, cmDlg, 64 | nil)), 65 | nil))); 66 | end; 67 | 68 | procedure TPickApp.HandleEvent(var Event: TEvent); 69 | var 70 | Control: Word; 71 | begin 72 | inherited HandleEvent(Event); 73 | if Event.What = evCommand then 74 | begin 75 | case Event.Command of 76 | cmDlg: 77 | begin 78 | PickWindow := New(PPickWindow, Init); 79 | control:=DeskTop^.ExecView(PickWindow); 80 | Dispose(PickWindow, Done); 81 | end; 82 | end; 83 | ClearEvent(Event) 84 | end; 85 | end; 86 | 87 | var 88 | PickApp: TPickApp; 89 | 90 | begin 91 | PickApp.Init; 92 | PickApp.Run; 93 | PickApp.Done; 94 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TVINPUT.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/TVINPUT.PAS -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TVMOUSE.PAS: -------------------------------------------------------------------------------- 1 | {SWAG=OOP.SWG, T.V. Mouse right button} 2 | program Localmenu; 3 | uses 4 | Drivers, Objects, Views, App, Menus; 5 | 6 | const 7 | cmNothing = 101; 8 | type 9 | 10 | TMyApp = object(TApplication) 11 | LocalMenu: PMenu; 12 | LocalMenuOpen: boolean; 13 | constructor Init; 14 | procedure GetEvent(var Event: TEvent); virtual; 15 | end; 16 | 17 | constructor TMyApp.Init; 18 | begin 19 | inherited Init; 20 | LocalMenu := NewMenu( 21 | NewItem('Item~1~', '', 0, cmNothing, hcNOContext, 22 | NewItem('Item~2~', '', 0, cmNothing, hcNoContext, 23 | nil))); 24 | 25 | LocalMenuOpen := false; 26 | EventMask := EventMask or evBroadcast; 27 | end; 28 | 29 | procedure TMyApp.GetEvent(var Event: TEvent); 30 | var 31 | MousePt: TPoint; 32 | R: TRect; 33 | Box: PMenuBox; 34 | NewEvent: TEvent; 35 | Code: Word; 36 | begin 37 | inherited GetEvent(Event); 38 | if ((Event.What = evMouseDown) AND (Event.Buttons = 39 | mbRightButton) AND NOT LocalMenuOpen) 40 | then 41 | begin 42 | LocalMenuOpen := true; 43 | MousePt := Event.Where; 44 | if (MousePt.X > 70) then MousePt.X := 70; 45 | 46 | if (MousePt.Y > 20) then MousePt.Y := 20; 47 | ClearEvent(Event); 48 | R.Assign(MousePt.X, MousePt.Y, MousePt.X+11, MousePt.Y+2); 49 | Box := new(PMenuBox, Init(R, LocalMenu, nil)); 50 | Code := ExecView(Box); 51 | Dispose(Box); 52 | LocalMenuOpen := false; 53 | NewEvent.What := evBroadcast; 54 | NewEvent.Command := code; 55 | PutEvent(NewEvent); 56 | end; 57 | end; 58 | var 59 | MyApp: TMyApp; 60 | begin 61 | MyApp.Init; 62 | MyApp.Run; 63 | MyApp.Done; 64 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TV_MISC.PAS: -------------------------------------------------------------------------------- 1 | type 2 | DialogData = record 3 | CheckBoxData: Word; 4 | RadioButtonData: Word; 5 | InputLineData: string[128]; 6 | end; 7 | 8 | var 9 | DemoDialogData: DialogData; 10 | 11 | ------------- 12 | with DemoDialogData do 13 | begin 14 | CheckboxData := 1; 15 | RadioButtonData := 2; 16 | InputLineData := 'Phone home.'; 17 | end; 18 | ------------- 19 | Dialog^.SetData(DemoDialogData); 20 | Control := DeskTop^.ExecView(Dialog); 21 | if Control <> cmCancel then Dialog^.GetData(DemoDialogData); 22 | ------------- -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TV_STUD/LIST.DAT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/romiras/turbo-pascal-archive/662f6dfe7619744b0627d0e09a6c7881ea8fa8af/User Interface/Turbo Vision/TV_STUD/LIST.DAT -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TV_STUD/STUDOBJ.PAS: -------------------------------------------------------------------------------- 1 | Unit StudObj; 2 | 3 | Interface 4 | Uses Objects; 5 | 6 | type 7 | PRecord = ^TRecord; 8 | TRecord = record 9 | Name: String[12]; 10 | Mark: Integer; 11 | end; 12 | 13 | PStudentInfo=^TStudentInfo; 14 | TStudentInfo=object(TObject) 15 | TransferRecord: TRecord; 16 | constructor Load(var S: TStream); 17 | procedure Store(var S: TStream); 18 | Procedure Print; Virtual; 19 | end; 20 | 21 | PStudentsColl=^TStudentsColl; 22 | TStudentsColl=object(TSortedCollection) 23 | function Compare(Key1, Key2: Pointer): Integer; virtual; 24 | end; 25 | 26 | 27 | const 28 | RStudentInfo: TStreamRec = ( 29 | ObjType: 55001; 30 | VmtLink: Ofs(TypeOf(TStudentInfo)^); 31 | Load: @TStudentInfo.Load; 32 | Store: @TStudentInfo.Store 33 | ); 34 | 35 | RStudentsColl: TStreamRec = ( 36 | ObjType: 55002; 37 | VmtLink: Ofs(TypeOf(TStudentsColl)^); 38 | Load: @TStudentsColl.Load; 39 | Store: @TStudentsColl.Store); 40 | 41 | 42 | var 43 | PC: PStudentsColl; 44 | 45 | 46 | Implementation 47 | Uses Drivers; 48 | 49 | type 50 | TLinkRecord = record 51 | PName: PString; 52 | PMark: longint; 53 | end; 54 | 55 | 56 | 57 | constructor TStudentInfo.Load(var S: TStream); 58 | begin 59 | Inherited Init; 60 | S.Read(TransferRecord, SizeOf(TransferRecord)); 61 | end; 62 | 63 | procedure TStudentInfo.Store(var S: TStream); 64 | begin 65 | S.Write(TransferRecord, SizeOf(TransferRecord)); 66 | end; 67 | 68 | Procedure TStudentInfo.Print; 69 | var str: string; 70 | LinkRecord: TLinkRecord; 71 | Begin 72 | with LinkRecord do 73 | begin 74 | PName := @TransferRecord.Name; 75 | PMark := TransferRecord.Mark; 76 | end; 77 | FormatStr (str,' %-24s%-4d', LinkRecord); 78 | writeln (str); 79 | End; 80 | 81 | {$i ..\sortfunc.inc} 82 | 83 | function TStudentsColl.Compare(Key1, Key2: Pointer): Integer; 84 | begin 85 | Compare:=StrICmp(PStudentInfo(Key1)^.TransferRecord.Name, PStudentInfo(Key2)^.TransferRecord.Name); 86 | end; 87 | 88 | 89 | begin 90 | 91 | { RegisterType (RSortedCollection);} 92 | RegisterType (RStudentsColl); 93 | RegisterType (RStudentInfo); 94 | 95 | end. -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TV_STUD/TV_OBJ.PAS: -------------------------------------------------------------------------------- 1 | Unit TV_Obj; 2 | 3 | Interface 4 | uses Objects, Drivers, Dialogs; 5 | 6 | type 7 | DataRec = record 8 | _Name : String[30]; 9 | _Mark : String[4]; 10 | end; 11 | PDataRec = ^DataRec; 12 | 13 | { TInfoDlg } 14 | 15 | PInfoDlg = ^TInfoDlg; 16 | TInfoDlg = object(TDialog) 17 | constructor Init; 18 | end; 19 | 20 | PStuDialog = ^TDialog; 21 | 22 | 23 | const 24 | cmViewList = 100; 25 | cmAdd = 110; 26 | cmEdit = 111; 27 | cmDelete = 112; 28 | cmSearch = 113; 29 | cmSave = 120; 30 | 31 | 32 | Implementation 33 | uses Views, MsgBox, Studobj; 34 | 35 | 36 | { TInfoDlg } 37 | 38 | constructor TInfoDlg.Init; 39 | var 40 | R: TRect; 41 | Control : PView; 42 | begin 43 | R.Assign(12, 4, 52, 15); 44 | inherited Init(R, 'Student info'); 45 | 46 | R.Assign(17, 7, 27, 9); 47 | Control := New(PButton, Init(R, 'O~K~', cmOK, bfDefault)); 48 | Insert(Control); 49 | 50 | R.Assign(28, 7, 38, 9); 51 | Control := New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)); 52 | Insert(Control); 53 | 54 | R.Assign(4, 4, 36, 5); 55 | Control := New(PInputLine, Init(R, 30)); 56 | Insert(Control); 57 | 58 | R.Assign(4, 3, 9, 4); 59 | Insert(New(PLabel, Init(R, '~N~ame', Control))); 60 | 61 | R.Assign(4, 7, 8, 8); 62 | Control := New(PInputLine, Init(R, 4)); 63 | Insert(Control); 64 | 65 | R.Assign(4, 6, 9, 7); 66 | Insert(New(PLabel, Init(R, '~M~ark', Control))); 67 | 68 | SelectNext(False); 69 | end; 70 | 71 | 72 | end. 73 | -------------------------------------------------------------------------------- /User Interface/Turbo Vision/TV_STUD/list.txt: -------------------------------------------------------------------------------- 1 | Petrov 2 | Ivanov 3 | Sidorov -------------------------------------------------------------------------------- /User Interface/Turbo Vision/USEOBJ.PAS: -------------------------------------------------------------------------------- 1 | uses objects; 2 | var PSC: PStringCollection; 3 | str:string[20]; 4 | i:byte; 5 | begin 6 | PSC := New(PStringCollection, Init(5,0)); 7 | writeln('Enter a string'); 8 | for i:=0 to 4 do 9 | begin 10 | readln(str); 11 | PSC^.Insert(NewStr(Str)); 12 | end; 13 | writeln; 14 | for i:=0 to 4 do 15 | writeln(i+1,' ',PString(PSC^.at(i))^); 16 | Dispose(PSC); 17 | end. --------------------------------------------------------------------------------