├── README.md ├── info.rkt └── minipascal ├── compiler-fpc.rkt ├── compiler-simple.rkt ├── compiler.rkt ├── experiments └── terminal.rkt ├── info.rkt ├── lang └── reader.rkt ├── mini-pascal-grammar.rkt ├── mini-pascal-lexer.rkt ├── runtime.rkt ├── semantics-simple.rkt ├── semantics.rkt ├── tests-basic ├── arithmetic.rkt ├── boolean.rkt ├── char.rkt ├── compound-statement.rkt ├── const-var-scope.rkt ├── constant-definitions.rkt ├── export-of-global-functions.rkt ├── fibonacci.rkt ├── for-statement.rkt ├── gcd.rkt ├── hello.rkt ├── long-sum.rkt ├── lowhigh.rkt ├── negative-constants.rkt ├── negative-index-range.rkt ├── relational-operators.rkt ├── stdlib-chr.rkt ├── type-definitions1.rkt └── type-definitions2.rkt ├── tests-fpc └── fpc-test.rkt ├── tests-medium ├── array-of-char.rkt ├── array-of-integer.rkt ├── array-with-char-index.rkt ├── function-with-no-arguments.rkt ├── function-with-one-argument.rkt ├── function-with-two-arguments.rkt ├── hcf.rkt ├── horner.rkt ├── nested-functions.rkt ├── procedure-with-no-arguments.rkt ├── procedure-with-two-arguments.rkt ├── strings.rkt └── write-natural.rkt ├── tests-numerical ├── pascal │ ├── ALG021.PAS │ ├── ALG022.PAS │ ├── ALG023.PAS │ ├── ALG024.PAS │ ├── ALG025.PAS │ ├── ALG026.PAS │ ├── ALG027.PAS │ ├── ALG028.PAS │ ├── ALG031.PAS │ ├── ALG032.PAS │ ├── ALG033.PAS │ ├── ALG034.PAS │ ├── ALG035.PAS │ ├── ALG036.PAS │ ├── ALG041.PAS │ ├── ALG042.PAS │ ├── ALG043.PAS │ ├── ALG044.PAS │ ├── ALG045.PAS │ ├── ALG046.PAS │ ├── ALG051.PAS │ ├── ALG052.PAS │ ├── ALG053.PAS │ ├── ALG054.PAS │ ├── ALG055.PAS │ ├── ALG056.PAS │ ├── ALG057.PAS │ ├── ALG058.PAS │ ├── ALG061.PAS │ ├── ALG062.PAS │ ├── ALG063.PAS │ ├── ALG064.PAS │ ├── ALG065.PAS │ ├── ALG066.PAS │ ├── ALG067.PAS │ ├── ALG071.PAS │ ├── ALG072.PAS │ ├── ALG073.PAS │ ├── ALG074.PAS │ ├── ALG075.PAS │ ├── ALG081.PAS │ ├── ALG082.PAS │ ├── ALG083.PAS │ ├── ALG091.PAS │ ├── ALG092.PAS │ ├── ALG093.PAS │ ├── ALG094.PAS │ ├── ALG095.PAS │ ├── ALG096.PAS │ ├── ALG101.PAS │ ├── ALG102.PAS │ ├── ALG103.PAS │ ├── ALG104.PAS │ ├── ALG111.PAS │ ├── ALG112.PAS │ ├── ALG113.PAS │ ├── ALG114.PAS │ ├── ALG115.PAS │ ├── ALG116.PAS │ ├── ALG121.PAS │ ├── ALG122.PAS │ ├── ALG123.PAS │ ├── ALG124.PAS │ ├── ALG125.PAS │ ├── dta │ │ ├── ALG031.DTA │ │ ├── ALG032.DTA │ │ ├── ALG033.DTA │ │ ├── ALG034.DTA │ │ ├── ALG035.DTA │ │ ├── ALG036.DTA │ │ ├── ALG061.DTA │ │ ├── ALG062.DTA │ │ ├── ALG063.DTA │ │ ├── ALG064.DTA │ │ ├── ALG065.DTA │ │ ├── ALG066.DTA │ │ ├── ALG067.DTA │ │ ├── ALG071.DTA │ │ ├── ALG072.DTA │ │ ├── ALG073.DTA │ │ ├── ALG074.DTA │ │ ├── ALG081.DTA │ │ ├── ALG082.DTA │ │ ├── ALG083.DTA │ │ ├── ALG091.DTA │ │ ├── ALG092.DTA │ │ ├── ALG093.DTA │ │ ├── ALG094.DTA │ │ ├── ALG095.DTA │ │ ├── ALG096.DTA │ │ ├── ALG115.DTA │ │ ├── ALG125.DTA │ │ └── alg075.dta │ └── readme_p.pdf └── readme.md ├── tests-real ├── primes.rkt └── stackoverflow-primes.rkt └── types.rkt /README.md: -------------------------------------------------------------------------------- 1 | MiniPascal 2 | ========== 3 | 4 | MiniPascal as a Racket language 5 | ------------------------------- 6 | 7 | This is the `minipascal` package. It provides MiniPascal 8 | as a new #lang language. 9 | 10 | After installation (see later) the following program will run 11 | as is in DrRacket. 12 | 13 | #lang minipascal 14 | program fact; 15 | type 16 | int=integer; 17 | function fact(n:int):int; 18 | begin 19 | if n=0 then 20 | fact:=1 21 | else 22 | fact:=n*fact(n-1) 23 | end; 24 | begin 25 | writeln(fact(10)); 26 | end. 27 | 28 | See `mini-pascal-grammar.rkt` for a complete grammar. 29 | 30 | Features 31 | -------- 32 | 33 | The following features are supported: 34 | - constant definitions 35 | - type definitions 36 | - function and procedure declarations 37 | - nested functions and procedures 38 | - base types: integer, boolean, char, 39 | - arrays 40 | - strings 41 | - integer and char can be used as index ranges 42 | 43 | Compilers 44 | --------- 45 | 46 | MiniPascal comes with two compilers. The simple one 47 | in "semantics-simple.rkt" translates directly from 48 | Pascal to Racket without any (compile time) type 49 | checking. This compiler is written in the same 50 | spirit as the example in the Ragg tutorial. In 51 | other words it "compiles by macro expansion". 52 | 53 | The other compiler in "semantics.rkt" demonstrates 54 | how scoping and type checking can by implemented. 55 | The compiler more traditional, it expands the whole 56 | Pascal program in one go. 57 | 58 | To switch from the full compiler to the simple one, 59 | add `simple` to the `#lang` line. That is, the lines: 60 | 61 | #lang minipascal 62 | #lang minipascal simple 63 | use the full and simple compiler respectively. 64 | 65 | Exercises 66 | --------- 67 | - Add mod as an operator 68 | - Add repeat 69 | - Add case 70 | - Add enumerated types 71 | - Add real numbers 72 | - Add records 73 | - Add files 74 | 75 | Installation 76 | ------------ 77 | 78 | Install this package from the command line with: 79 | 80 | ```sh 81 | raco pkg install --deps search-ask minipascal 82 | ``` 83 | 84 | or, by evaluating the following in DrRacket: 85 | 86 | ```racket 87 | #lang racket 88 | 89 | (require pkg) 90 | (install "minipascal" #:deps 'search-ask) 91 | ``` 92 | 93 | Use the Racket package manager to install: 94 | 95 | ``` 96 | raco pkg install minipascal 97 | ``` 98 | 99 | References 100 | ---------- 101 | Pascal ISO 7185 from 1990: 102 | http://pascal-central.com/docs/iso7185.pdf 103 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define version "1.0") 4 | (define deps '("ragg" "base" 5 | "parser-tools-lib")) 6 | 7 | 8 | (define build-deps '("base" 9 | "parser-tools-lib" 10 | "at-exp-lib" 11 | "rackunit-lib" 12 | "scribble-lib" 13 | "racket-doc")) 14 | 15 | 16 | -------------------------------------------------------------------------------- /minipascal/compiler-fpc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide compile/fpc) 3 | ;;; 4 | ;;; COMPILE USING FREE PASCAL 5 | ;;; 6 | 7 | ; This file contains a "compiler" that uses the 8 | ; Free Pascal Compiler (fpc) to compile the Pascal 9 | ; program. After compilation the resulting 10 | ; executable is run. This "compiler" makes it 11 | ; easy to make conformance tests. 12 | 13 | ; Compiling a file "foo.rkt" containing a MiniPascal 14 | ; is a done as follows: 15 | 16 | ; 1. The contents of "foo.rkt" minus the #lang line 17 | ; is written to "foo.pas". 18 | ; 2. The Free Pascal Compiler is invoked: 19 | ; fpc foo.pas 20 | ; This produces "foo". 21 | ; 3. The program "foo" is run with standard 22 | ; input and output wired to Racket's 23 | ; standard in- and outputs. 24 | 25 | (require racket/file) 26 | 27 | (define (generate-pas-file ip) 28 | ; Note: The reader has at this point already 29 | ; removed the #lang line 30 | (define pas-file 31 | (make-temporary-file "~a.pas" #f (current-directory))) 32 | (with-output-to-file pas-file 33 | (λ () (copy-port ip (current-output-port))) 34 | #:exists 'truncate) 35 | pas-file) 36 | 37 | (define (fpc-compile pas-file) 38 | (define out-file 39 | (make-temporary-file "~a.out" #f (current-directory))) 40 | (define (compile) 41 | (system* "/usr/local/bin/fpc" 42 | "-k-macosx_version_min 10.6" 43 | (~a "-o" out-file) 44 | pas-file)) 45 | (define exit-code 0) 46 | (define output (with-output-to-string 47 | (λ () (set! exit-code (compile))))) 48 | (cond 49 | [exit-code 50 | (define permissions 51 | (bitwise-ior user-execute-bit user-read-bit user-write-bit)) 52 | (file-or-directory-permissions out-file permissions) 53 | out-file] 54 | [else 55 | (displayln output) 56 | #f])) 57 | 58 | (define (run out-file input) 59 | (define in 60 | (cond 61 | [(string? input) (open-input-string input)] 62 | [(port? input) input] 63 | [(eq? input #f) (current-input-port)])) 64 | (parameterize ([current-input-port in]) 65 | (system* out-file))) 66 | 67 | (define (compile/fpc src ip input) 68 | (define pas-file (generate-pas-file ip)) 69 | (define out-file (fpc-compile pas-file)) 70 | (when out-file 71 | (run out-file input) 72 | (delete-file out-file)) 73 | (delete-file pas-file) 74 | (quasisyntax/loc #'here 75 | (module fpc racket/base 76 | (void)))) 77 | -------------------------------------------------------------------------------- /minipascal/experiments/terminal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (planet neil/charterm)) 4 | 5 | (with-charterm 6 | (charterm-clear-screen) 7 | (charterm-cursor 10 5) 8 | (charterm-display "Hello, ") 9 | (charterm-bold) 10 | (charterm-display "you") 11 | (charterm-normal) 12 | (charterm-display ".") 13 | (charterm-cursor 1 1) 14 | (charterm-display "Press a key...") 15 | (let ((key (charterm-read-key))) 16 | (charterm-cursor 1 1) 17 | (charterm-clear-line) 18 | (printf "You pressed: ~S\r\n" key))) 19 | -------------------------------------------------------------------------------- /minipascal/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define compile-omit-paths '("experiments" 4 | "tests-basic" 5 | "tests-medium" 6 | "tests-advanced" 7 | "tests-real" 8 | "tests-numerical" 9 | "tests-fpc")) 10 | 11 | (define test-omit-paths '("experiments" 12 | "tests-basic" 13 | "tests-medium" 14 | "tests-advanced" 15 | "tests-real" 16 | "tests-numerical" 17 | "tests-fpc")) 18 | -------------------------------------------------------------------------------- /minipascal/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide 3 | (rename-out [my-read read] 4 | [my-read-syntax read-syntax] 5 | [my-get-info get-info])) 6 | 7 | (require "../mini-pascal-lexer.rkt" 8 | "../mini-pascal-grammar.rkt") 9 | 10 | (require "../compiler.rkt" 11 | "../compiler-fpc.rkt") 12 | 13 | ; In order to specify paths relative to the 14 | ; path of "reader.rkt" (rather than the file 15 | ; containing the file to be read) we use 16 | ; runtime-paths. 17 | (require racket/runtime-path) 18 | (define-runtime-path sem-simple-path "../semantics-simple.rkt") 19 | (define-runtime-path color-lexer-path "../mini-pascal-lexer.rkt") 20 | 21 | ; read-syntax runs the lexer and parser on the 22 | ; input port containing the pascal program. 23 | ; The parser returns a syntax object of the form: 24 | ; (program (block ...)) 25 | ; This syntax object is wrapped in a module, 26 | ; whose language is specified in "semantics.rkt". 27 | ; In "semantics.rkt" program is a macro that 28 | ; compiles (block ...) into the language 29 | ; specified in the "runtime.rkt". 30 | 31 | (define mode 'full) 32 | 33 | (define (my-read-syntax src ip) 34 | (define after-minipascal (read-line ip)) 35 | ; determine which compiler to use 36 | ; #lang minipascal simple => semantics-simple.rkt 37 | ; #lang minipascal => compiler.rkt 38 | ; #lang fpc => compile-fpc.rkt 39 | (define test-input #f) 40 | (define after (open-input-string after-minipascal)) 41 | ; look for options 42 | (let loop () 43 | (define option (read after)) 44 | (unless (eof-object? option) 45 | (match option 46 | ['simple (set! mode 'simple)] 47 | ['fpc (set! mode 'fpc)] 48 | [(list 'input str) (set! test-input str)] 49 | [_ (displayln (~a "unrecognized option: " option))]) 50 | (loop))) 51 | ; parse and compile 52 | (case mode 53 | [(simple) 54 | (define parse-tree (parse src (lex ip))) 55 | (quasisyntax/loc #'here 56 | (module minipascal #,sem-simple-path 57 | #,parse-tree))] 58 | [(full) 59 | (define parse-tree (parse src (lex ip))) 60 | (define prg (compile-program parse-tree)) 61 | ; (displayln prg) 62 | prg] 63 | [(fpc) 64 | (define prg (compile/fpc src ip test-input)) 65 | prg])) 66 | 67 | ; read returns the same as read-syntax, 68 | ; except as a datum. 69 | (define (my-read in) 70 | (syntax->datum (my-read-syntax #f in))) 71 | 72 | ; get-info is in general used by external 73 | ; tools to retrieve information about a 74 | ; program. Here we use get-info to tell 75 | ; DrRacket which lexer it should use to 76 | ; syntax color Pascal programs. 77 | (define (my-get-info in mod line col pos) 78 | (lambda (key default) 79 | (case key 80 | [(color-lexer) 81 | (dynamic-require color-lexer-path 'color-lex)] 82 | [else default]))) 83 | -------------------------------------------------------------------------------- /minipascal/mini-pascal-grammar.rkt: -------------------------------------------------------------------------------- 1 | #lang ragg 2 | ;;; MiniPascal 3 | 4 | program : "program" IDENTIFIER ";" block "." 5 | block : constant-definition-part 6 | type-definition-part 7 | variable-declaration-part 8 | procedure-and-function-declaration-part 9 | statement-part 10 | 11 | constant-definition-part : ["const" (constant-definition ";")+] 12 | constant-definition : IDENTIFIER ("," IDENTIFIER)* "=" INTEGER-CONSTANT 13 | 14 | type-definition-part : ["type" (type-definition ";")+] 15 | type-definition : IDENTIFIER "=" type 16 | 17 | variable-declaration-part : ["var" (variable-declaration ";")+] 18 | variable-declaration : IDENTIFIER ("," IDENTIFIER)* ":" type 19 | 20 | type : simple-type | array-type 21 | array-type : "array" "[" index-type "]" "of" simple-type 22 | index-type : type-identifier | index-range 23 | index-constant : [sign] INTEGER-CONSTANT | CHARACTER-CONSTANT | [sign] constant-name 24 | index-range : index-constant ".." index-constant 25 | simple-type : type-identifier | index-range 26 | constant-name : IDENTIFIER 27 | type-identifier : IDENTIFIER 28 | 29 | 30 | procedure-and-function-declaration-part : 31 | ((procedure-declaration ";") | (function-declaration ";"))* 32 | 33 | procedure-declaration : "procedure" IDENTIFIER 34 | ["(" formal-parameters (";" formal-parameters)* ")"] ";" 35 | block 36 | formal-parameters : IDENTIFIER ("," IDENTIFIER)* ":" type 37 | 38 | function-declaration : "function" IDENTIFIER 39 | ["(" formal-parameters (";" formal-parameters)* ")"] 40 | ":" type-identifier ";" block 41 | 42 | 43 | statement-part : compound-statement 44 | compound-statement : "begin" [statement (";"+ statement)*] [";"+] "end" 45 | statement : simple-statement | structured-statement 46 | simple-statement : assignment-statement | procedure-statement | 47 | application | read-statement | 48 | write-statement | writeln-statement 49 | assignment-statement : variable ["[" expression "]"] ":=" expression 50 | procedure-statement : procedure-identifier 51 | application : IDENTIFIER "(" expression ("," expression)* ")" 52 | read-statement : ("readln"|"read") "(" IDENTIFIER ("," IDENTIFIER)* ")" 53 | write-statement : "write" "(" output-value ("," output-value)* ")" 54 | writeln-statement : "writeln" ["(" output-value ("," output-value)* ")"] 55 | 56 | procedure-identifier : IDENTIFIER 57 | output-value : expression 58 | 59 | structured-statement : compound-statement | if-statement | while-statement | for-statement 60 | if-statement : "if" expression "then" statement | 61 | "if" expression "then" statement "else" statement 62 | while-statement : "while" expression "do" statement 63 | for-statement : "for" IDENTIFIER ":=" expression ("to"|"downto") expression "do" statement 64 | 65 | expression : simple-expression | 66 | simple-expression relational-operator simple-expression 67 | simple-expression : [sign] term (adding-operator term)* 68 | term : factor (multiplying-operator factor)* 69 | factor : application | variable | constant | "(" expression ")" | "not" factor 70 | relational-operator : "=" | "<>" | "<" | "<=" | ">=" | ">" 71 | sign : "+" | "-" 72 | adding-operator : "+" | "-" | "or" 73 | multiplying-operator : "*" | "div" | "and" 74 | 75 | variable : IDENTIFIER | IDENTIFIER "[" expression "]" 76 | parameter-identifier : IDENTIFIER 77 | 78 | ;; Lexical grammar 79 | constant : [sign] (INTEGER-CONSTANT | constant-identifier) 80 | | CHARACTER-CONSTANT | STRING-CONSTANT 81 | constant-identifier : IDENTIFIER 82 | -------------------------------------------------------------------------------- /minipascal/mini-pascal-lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;; 3 | ;;; LEXER 4 | ;;; 5 | 6 | ; This module defines two lexers for MiniPascal. 7 | 8 | (provide lex color-lex) 9 | 10 | ; The main one, lex, returns tokens to 11 | ; be used by the ragg parser. 12 | 13 | ; The other one, color-lex, returns tokens 14 | ; to be used by DrRacket to syntax color 15 | ; Pascal programs. 16 | 17 | (require ragg/support parser-tools/lex) 18 | 19 | ; Reserved keywords in Pacal ignore case. 20 | ; Thus the "PrOgRaM" and "program" are 21 | ; the same keyword. Since the lexer has 22 | ; no builtin support for matching mixed case 23 | ; strings, we define our own lexer 24 | ; transformation, mixed, that turns 25 | ; (mixed "foo") into 26 | ; (concatenation 27 | ; (union #\f #\F) (union #\o #\o) (union #\o #\o)) 28 | ; Remember to use string-downcase on the 29 | ; resulting lexeme. 30 | 31 | (require (for-syntax syntax/parse)) 32 | (define-lex-trans mixed 33 | (λ (stx) 34 | (syntax-parse stx 35 | [(_ datum) 36 | (define str (string-downcase (syntax->datum #'datum))) 37 | (define STR (string-upcase str)) 38 | #`(concatenation 39 | #,@(for/list ([c (in-string str)] 40 | [C (in-string STR)]) 41 | #`(union #,c #,C)))]))) 42 | 43 | ; The following lexer transformation turns 44 | ; (union-mixed "foo" "bar") into 45 | ; (union (mixed "foo") (mixed "bar")) 46 | 47 | (define-lex-trans union-mixed 48 | (λ (stx) 49 | (syntax-parse stx 50 | [(_ str ...) 51 | #`(union (mixed str) ...)]))) 52 | 53 | ; Since we want to define two lexers, it is 54 | ; convenient to define lexer abbreviations 55 | ; that can be used in both lexers. 56 | 57 | (define-lex-abbrevs 58 | [letter 59 | (union (char-range #\a #\z) (char-range #\A #\Z))] 60 | [digit 61 | (char-range #\0 #\9)] 62 | [identifier 63 | (concatenation letter 64 | (repetition 0 +inf.0 (union letter digit)))] 65 | [integer ; non-negative 66 | (repetition 1 +inf.0 digit)] 67 | [char-constant 68 | (union (concatenation #\' (char-complement #\') #\') "''''")] 69 | [string-content 70 | (union (char-complement #\') "''")] 71 | [string-constant 72 | (union (concatenation #\' (repetition 0 +inf.0 string-content) #\'))] 73 | [reserved 74 | (union-mixed 75 | "div" "or" "and" "not" "if" "for" "to" "downto" 76 | "then" "else" "of" "while" "do" "begin" "end" 77 | "read" "readln" "write" "writeln" 78 | "var" "const" "array" "type" "bindable" 79 | "procedure" "function" "program")] 80 | [slash-comment 81 | (concatenation "//" (repetition 0 +inf.0 (char-complement #\newline)))] 82 | [curly-comment 83 | (concatenation #\{ (repetition 0 +inf.0 (char-complement #\})) #\})] 84 | [comment 85 | (union slash-comment curly-comment)] 86 | [operators 87 | (union "+" "-" "*" "=" "<>" "<" ">" "<=" ">=" ":=")] 88 | [brackets 89 | (union "(" ")" "[" "]")] 90 | [other-delimiters 91 | (union "." "," ";" ":" "..")] 92 | [delimiters 93 | (union operators brackets other-delimiters)]) 94 | 95 | (define (string-remove-ends str) 96 | (substring str 1 (sub1 (string-length str)))) 97 | 98 | ;; Lexer for MiniPascal 99 | (define (lex ip) 100 | (port-count-lines! ip) 101 | (define my-lexer 102 | (lexer-src-pos 103 | [(union "integer" "char" "boolean" "true" "false") 104 | (token 'IDENTIFIER (string->symbol lexeme))] 105 | [(union reserved delimiters) ; includes operators 106 | (string-downcase lexeme)] 107 | [identifier 108 | (token 'IDENTIFIER (string->symbol (string-downcase lexeme)))] 109 | [integer 110 | (token 'INTEGER-CONSTANT (string->number lexeme))] 111 | [char-constant 112 | (if (equal? lexeme "''''") 113 | (token 'CHARACTER-CONSTANT #\') 114 | (token 'CHARACTER-CONSTANT (string-ref lexeme 1)))] 115 | [string-constant 116 | (token 'STRING-CONSTANT 117 | (regexp-replace* "''" (string-remove-ends lexeme) "'"))] 118 | [whitespace 119 | (token 'WHITESPACE lexeme #:skip? #t)] 120 | [comment 121 | (token 'COMMENT lexeme #:skip? #t)] 122 | [(eof) 123 | (void)])) 124 | (define (next-token) 125 | (my-lexer ip)) 126 | next-token) 127 | 128 | ;;; 129 | ;;; COLOR LEXER 130 | ;;; 131 | 132 | ; This lexer is used by DrRacket to color the Pacal program. 133 | 134 | ; The color lexer returns 5 values: 135 | ; - Either a string containing the matching text or the eof object. 136 | ; Block comments and specials currently return an empty string. 137 | ; This may change in the future to other string or non-string data. 138 | ; - A symbol in '(error comment sexp-comment white-space constant 139 | ; string no-color parenthesis other symbol eof). 140 | ; - A symbol in '(|(| |)| |[| |]| |{| |}|) or #f. 141 | ; - A number representing the starting position of the match (or #f if eof). 142 | ; - A number representing the ending position of the match (or #f if eof). 143 | 144 | (define (syn-val a b c d e) 145 | (values a ; string with matching text 146 | b ; symbol in '(comment white-space no-color eof) 147 | c ; symbol in '(|(| |)| |[| |]| |{| |}|) or #f. 148 | (position-offset d) ; start pos 149 | (max ; end pos 150 | (position-offset e) 151 | (+ (position-offset d) 1)))) 152 | 153 | (define color-lex 154 | ; REMEMBER to restart DrRacket to test any changes in the 155 | ; color-lexer. The lexer is only imported into DrRacket 156 | ; at startup. 157 | (lexer 158 | [(eof) 159 | (syn-val lexeme 'eof #f start-pos end-pos)] 160 | [reserved 161 | (syn-val lexeme 'keyword #f start-pos end-pos)] 162 | [brackets 163 | (syn-val lexeme 'parenthesis (string->symbol lexeme) start-pos end-pos)] 164 | [whitespace 165 | (syn-val lexeme 'white-space #f start-pos end-pos)] 166 | [slash-comment 167 | (syn-val lexeme 'comment #f start-pos end-pos)] 168 | [curly-comment 169 | (syn-val lexeme 'sexp-comment #f start-pos end-pos)] 170 | [(union "{" "}") 171 | (syn-val lexeme 'sexp-comment (string->symbol lexeme) start-pos end-pos)] 172 | #;[operators 173 | (syn-val lexeme 'symbol #f start-pos end-pos)] 174 | [string-constant 175 | (syn-val lexeme 'string #f start-pos end-pos)] 176 | [identifier 177 | (syn-val lexeme 'identifier #f start-pos end-pos)] 178 | [(union integer char-constant) 179 | (syn-val lexeme 'constant #f start-pos end-pos)] 180 | [delimiters 181 | (syn-val lexeme 'no-color #f start-pos end-pos)] 182 | [any-char ; anything else is an error (red) 183 | (syn-val lexeme 'error #f start-pos end-pos)])) 184 | -------------------------------------------------------------------------------- /minipascal/semantics-simple.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-from-out "runtime.rkt")) 3 | 4 | (require "runtime.rkt") 5 | (require (for-syntax "compiler-simple.rkt")) 6 | 7 | ; The macro, program, compiles the syntax-object 8 | ; the parser returned into a Racket program written 9 | ; in the language specified in "runtime.rkt". 10 | 11 | (provide program) 12 | (define-syntax (program stx) 13 | (displayln "Input program:") 14 | (displayln stx) 15 | (displayln "Compiled program:") 16 | 17 | (define compiled (compile-program stx)) 18 | 19 | (displayln compiled) 20 | (displayln "Running program:") 21 | 22 | compiled) 23 | 24 | ; In "compiler-simple.rkt" the output contains 25 | ; forms such as (term ...). To get the macro 26 | ; expander to expand the term with compile-term, 27 | ; we must set up a macro, term, that simply 28 | ; uses compile-term to compute the expansion. 29 | ; This must be done for each non-terminal. 30 | 31 | ; As a convenience the 32 | ; following macro, generate-macro, is used to 33 | ; define and provide a bunch of these macros. 34 | 35 | (require (for-syntax syntax/parse 36 | racket/syntax)) 37 | 38 | (define-syntax (generate-macros stx) 39 | (syntax-parse stx 40 | [(_ id ...) 41 | (with-syntax ([(compile-id ...) 42 | (map (λ (id) (format-id id "compile-~a" id)) 43 | (syntax->list #'(id ...)))]) 44 | #'(begin 45 | (define-syntax id compile-id) ... 46 | (provide id ...)))])) 47 | 48 | (generate-macros 49 | constant-definition-part constant-definition 50 | type-definition-part type-definition 51 | variable-declaration-part variable-declaration 52 | procedure-and-function-declaration-part 53 | procedure-declaration function-declaration 54 | block statement-part statement compound-statement 55 | simple-statement assignment-statement read-statement 56 | write-statement writeln-statement 57 | procedure-statement structured-statement 58 | if-statement while-statement for-statement 59 | expression simple-expression term factor constant 60 | constant-identifier output-value application 61 | relational-operator multiplying-operator 62 | variable procedure-identifier sign) 63 | -------------------------------------------------------------------------------- /minipascal/semantics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;; Not used. 4 | 5 | ; The full compiler in "compiler.rkt" expands 6 | ; a the parse tree into a module directly. 7 | ; Thus a semantics module is not needed. 8 | -------------------------------------------------------------------------------- /minipascal/tests-basic/arithmetic.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests aritmetics functions. 3 | Expected result: 1,2,3,4,5,6,7,8,9,10,11 } 4 | program arithmetic; 5 | begin 6 | writeln(1); 7 | writeln(1+1); 8 | writeln(2*1+1); 9 | writeln((1+1)+2); 10 | writeln(3+1*2); 11 | writeln(3*2); 12 | writeln(2*2*2-1); 13 | writeln(16 div 2); 14 | writeln(16 div 2 + 1); 15 | writeln((2+3)*2); 16 | writeln(100 div 9); 17 | end. 18 | 19 | -------------------------------------------------------------------------------- /minipascal/tests-basic/boolean.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests boolean operators 3 | Expected result: alterning true, false, ...} 4 | program arithmetic; 5 | begin 6 | writeln(true); 7 | writeln(false); 8 | writeln(not false); 9 | writeln(not true); 10 | writeln(true or false); 11 | writeln(true and false); 12 | writeln(not (true and false)); 13 | writeln(not (true or false)); 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /minipascal/tests-basic/char.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests printing of characters. 3 | Expected result: Prints character number 0 to 255 in order.} 4 | program arithmetic; 5 | begin 6 | writeln(''); 7 | writeln(''); 8 | writeln(''); 9 | writeln(''); 10 | writeln(''); 11 | writeln(''); 12 | writeln(''); 13 | writeln(''); 14 | writeln(''); 15 | writeln(' '); 16 | writeln(' 17 | '); 18 | writeln(' '); 19 | writeln(' '); 20 | writeln(' 21 | '); 22 | writeln(''); 23 | writeln(''); 24 | writeln(''); 25 | writeln(''); 26 | writeln(''); 27 | writeln(''); 28 | writeln(''); 29 | writeln(''); 30 | writeln(''); 31 | writeln(''); 32 | writeln(''); 33 | writeln(''); 34 | writeln(''); 35 | writeln(''); 36 | writeln(''); 37 | writeln(''); 38 | writeln(''); 39 | writeln(''); 40 | writeln(' '); 41 | writeln('!'); 42 | writeln('"'); 43 | writeln('#'); 44 | writeln('$'); 45 | writeln('%'); 46 | writeln('&'); 47 | writeln(''''); 48 | writeln('('); 49 | writeln(')'); 50 | writeln('*'); 51 | writeln('+'); 52 | writeln(','); 53 | writeln('-'); 54 | writeln('.'); 55 | writeln('/'); 56 | writeln('0'); 57 | writeln('1'); 58 | writeln('2'); 59 | writeln('3'); 60 | writeln('4'); 61 | writeln('5'); 62 | writeln('6'); 63 | writeln('7'); 64 | writeln('8'); 65 | writeln('9'); 66 | writeln(':'); 67 | writeln(';'); 68 | writeln('<'); 69 | writeln('='); 70 | writeln('>'); 71 | writeln('?'); 72 | writeln('@'); 73 | writeln('A'); 74 | writeln('B'); 75 | writeln('C'); 76 | writeln('D'); 77 | writeln('E'); 78 | writeln('F'); 79 | writeln('G'); 80 | writeln('H'); 81 | writeln('I'); 82 | writeln('J'); 83 | writeln('K'); 84 | writeln('L'); 85 | writeln('M'); 86 | writeln('N'); 87 | writeln('O'); 88 | writeln('P'); 89 | writeln('Q'); 90 | writeln('R'); 91 | writeln('S'); 92 | writeln('T'); 93 | writeln('U'); 94 | writeln('V'); 95 | writeln('W'); 96 | writeln('X'); 97 | writeln('Y'); 98 | writeln('Z'); 99 | writeln('['); 100 | writeln('\'); 101 | writeln(']'); 102 | writeln('^'); 103 | writeln('_'); 104 | writeln('`'); 105 | writeln('a'); 106 | writeln('b'); 107 | writeln('c'); 108 | writeln('d'); 109 | writeln('e'); 110 | writeln('f'); 111 | writeln('g'); 112 | writeln('h'); 113 | writeln('i'); 114 | writeln('j'); 115 | writeln('k'); 116 | writeln('l'); 117 | writeln('m'); 118 | writeln('n'); 119 | writeln('o'); 120 | writeln('p'); 121 | writeln('q'); 122 | writeln('r'); 123 | writeln('s'); 124 | writeln('t'); 125 | writeln('u'); 126 | writeln('v'); 127 | writeln('w'); 128 | writeln('x'); 129 | writeln('y'); 130 | writeln('z'); 131 | writeln('{'); 132 | writeln('|'); 133 | writeln('}'); 134 | writeln('~'); 135 | writeln(''); 136 | writeln('€'); 137 | writeln(''); 138 | writeln('‚'); 139 | writeln('ƒ'); 140 | writeln('„'); 141 | writeln('…'); 142 | writeln('†'); 143 | writeln('‡'); 144 | writeln('ˆ'); 145 | writeln('‰'); 146 | writeln('Š'); 147 | writeln('‹'); 148 | writeln('Œ'); 149 | writeln(''); 150 | writeln('Ž'); 151 | writeln(''); 152 | writeln(''); 153 | writeln('‘'); 154 | writeln('’'); 155 | writeln('“'); 156 | writeln('”'); 157 | writeln('•'); 158 | writeln('–'); 159 | writeln('—'); 160 | writeln('˜'); 161 | writeln('™'); 162 | writeln('š'); 163 | writeln('›'); 164 | writeln('œ'); 165 | writeln(''); 166 | writeln('ž'); 167 | writeln('Ÿ'); 168 | writeln(' '); 169 | writeln('¡'); 170 | writeln('¢'); 171 | writeln('£'); 172 | writeln('¤'); 173 | writeln('¥'); 174 | writeln('¦'); 175 | writeln('§'); 176 | writeln('¨'); 177 | writeln('©'); 178 | writeln('ª'); 179 | writeln('«'); 180 | writeln('¬'); 181 | writeln('­'); 182 | writeln('®'); 183 | writeln('¯'); 184 | writeln('°'); 185 | writeln('±'); 186 | writeln('²'); 187 | writeln('³'); 188 | writeln('´'); 189 | writeln('µ'); 190 | writeln('¶'); 191 | writeln('·'); 192 | writeln('¸'); 193 | writeln('¹'); 194 | writeln('º'); 195 | writeln('»'); 196 | writeln('¼'); 197 | writeln('½'); 198 | writeln('¾'); 199 | writeln('¿'); 200 | writeln('À'); 201 | writeln('Á'); 202 | writeln('Â'); 203 | writeln('Ã'); 204 | writeln('Ä'); 205 | writeln('Å'); 206 | writeln('Æ'); 207 | writeln('Ç'); 208 | writeln('È'); 209 | writeln('É'); 210 | writeln('Ê'); 211 | writeln('Ë'); 212 | writeln('Ì'); 213 | writeln('Í'); 214 | writeln('Î'); 215 | writeln('Ï'); 216 | writeln('Ð'); 217 | writeln('Ñ'); 218 | writeln('Ò'); 219 | writeln('Ó'); 220 | writeln('Ô'); 221 | writeln('Õ'); 222 | writeln('Ö'); 223 | writeln('×'); 224 | writeln('Ø'); 225 | writeln('Ù'); 226 | writeln('Ú'); 227 | writeln('Û'); 228 | writeln('Ü'); 229 | writeln('Ý'); 230 | writeln('Þ'); 231 | writeln('ß'); 232 | writeln('à'); 233 | writeln('á'); 234 | writeln('â'); 235 | writeln('ã'); 236 | writeln('ä'); 237 | writeln('å'); 238 | writeln('æ'); 239 | writeln('ç'); 240 | writeln('è'); 241 | writeln('é'); 242 | writeln('ê'); 243 | writeln('ë'); 244 | writeln('ì'); 245 | writeln('í'); 246 | writeln('î'); 247 | writeln('ï'); 248 | writeln('ð'); 249 | writeln('ñ'); 250 | writeln('ò'); 251 | writeln('ó'); 252 | writeln('ô'); 253 | writeln('õ'); 254 | writeln('ö'); 255 | writeln('÷'); 256 | writeln('ø'); 257 | writeln('ù'); 258 | writeln('ú'); 259 | writeln('û'); 260 | writeln('ü'); 261 | writeln('ý'); 262 | writeln('þ'); 263 | end. 264 | -------------------------------------------------------------------------------- /minipascal/tests-basic/compound-statement.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests compound statements. 3 | Expected result: Prints 1,2,3,4,5,6 } 4 | program compund; 5 | begin 6 | begin 7 | end; 8 | begin 9 | writeln(1); 10 | end; 11 | begin 12 | writeln(2); 13 | writeln(3); 14 | end; 15 | begin 16 | writeln(4); 17 | writeln(5); 18 | writeln(6); 19 | end 20 | end. 21 | -------------------------------------------------------------------------------- /minipascal/tests-basic/const-var-scope.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests: Global constants and variables are in the same scope} 3 | { Expected: A duplicate binding error } 4 | program scopetest; 5 | const 6 | n=42; 7 | var 8 | n:integer; 9 | begin 10 | writeln(n); 11 | end. 12 | -------------------------------------------------------------------------------- /minipascal/tests-basic/constant-definitions.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests constant definitions 3 | Expected result: Prints 1,2,3 } 4 | { Note: The MiniPascal grammar only allows 5 | integer constant definitions. } 6 | program constdef; 7 | const 8 | x=1; y=2; z=3; 9 | begin 10 | writeln(x,y,z); 11 | end. 12 | -------------------------------------------------------------------------------- /minipascal/tests-basic/export-of-global-functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gcd.rkt") 3 | (gcd 34 35) 4 | -------------------------------------------------------------------------------- /minipascal/tests-basic/fibonacci.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | program fib; 3 | type 4 | int=integer; 5 | function fib(n:int):int; 6 | begin 7 | if n=0 then 8 | fib:=1 9 | else 10 | fib:=n*fib(n-1) 11 | end; 12 | begin 13 | writeln(fib(10)); 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /minipascal/tests-basic/for-statement.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test for-statements. 3 | Expected result: 55,55,abc,cba } 4 | 5 | program forstatement; 6 | var 7 | x,sum:integer; 8 | c:char; 9 | begin 10 | sum:=0; 11 | for x := 1 to 10 do 12 | sum:=sum+x; 13 | writeln(sum); 14 | 15 | sum:=0; 16 | for x := 10 downto 1 do 17 | sum:=sum+x; 18 | writeln(sum); 19 | 20 | for c := 'a' to 'c' do 21 | write(c); 22 | writeln; 23 | for c := 'c' downto 'a' do 24 | write(c); 25 | writeln; 26 | end. 27 | 28 | -------------------------------------------------------------------------------- /minipascal/tests-basic/gcd.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests recursive function calls. 3 | Expected result: 2*3*5 = 30 } 4 | program gcd; 5 | function rem(x,y:integer):integer; 6 | {Remainder of x divided by y} 7 | begin 8 | rem:= x-((x div y)*y); 9 | end; 10 | function gcd(x,y:integer):integer; 11 | {Greatest common divisor} 12 | begin 13 | { write('x',' ',x,' ',' ','y',' ',y); writeln; } 14 | if x>y then 15 | gcd:=gcd(y,x) 16 | else if x=0 then 17 | gcd:=y 18 | else 19 | gcd:=gcd(rem(y,x),x) 20 | end; 21 | begin 22 | writeln(gcd(2*2*3*3*5*7,2*3*5*11)); 23 | end. 24 | -------------------------------------------------------------------------------- /minipascal/tests-basic/hello.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | program HelloWorld; 3 | begin 4 | write('h','e','l','l','o'); 5 | writeln; 6 | write('w','o','r','l','d','!'); 7 | writeln; 8 | writeln; 9 | end. -------------------------------------------------------------------------------- /minipascal/tests-basic/long-sum.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | {Test robustness of arithmetic expressions. 3 | Expected result: 32640} 4 | program longsum; 5 | begin 6 | writeln( 7 | 0+1+2+3+4+5+6+7+8+9+10+11+12+13+14+15+16+17+18+19+20 8 | +21+22+23+24+25+26+27+28+29+30+31+32+33+34+35+36+37 9 | +38+39+40+41+42+43+44+45+46+47+48+49+50+51+52+53+54 10 | +55+56+57+58+59+60+61+62+63+64+65+66+67+68+69+70+71 11 | +72+73+74+75+76+77+78+79+80+81+82+83+84+85+86+87+88 12 | +89+90+91+92+93+94+95+96+97+98+99+100+101+102+103 13 | +104+105+106+107+108+109+110+111+112+113+114+115 14 | +116+117+118+119+120+121+122+123+124+125+126+127 15 | +128+129+130+131+132+133+134+135+136+137+138+139 16 | +140+141+142+143+144+145+146+147+148+149+150+151 17 | +152+153+154+155+156+157+158+159+160+161+162+163 18 | +164+165+166+167+168+169+170+171+172+173+174+175 19 | +176+177+178+179+180+181+182+183+184+185+186+187 20 | +188+189+190+191+192+193+194+195+196+197+198+199 21 | +200+201+202+203+204+205+206+207+208+209+210+211 22 | +212+213+214+215+216+217+218+219+220+221+222+223 23 | +224+225+226+227+228+229+230+231+232+233+234+235 24 | +236+237+238+239+240+241+242+243+244+245+246+247 25 | +248+249+250+251+252+253+254+255 26 | ); 27 | end. -------------------------------------------------------------------------------- /minipascal/tests-basic/lowhigh.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | {Tests the array functions low and high} 3 | program lowhigh; 4 | type 5 | string = array [ 0 ..255] of char; 6 | counts = array ['a'..'z'] of integer; 7 | var 8 | deadbeef: string; 9 | i,n:integer; 10 | c:char; 11 | count:counts; 12 | begin 13 | deadbeef:='deadbeef'; 14 | write('low: ', low(deadbeef)); 15 | writeln; 16 | write('high: ', high(deadbeef)); 17 | writeln; 18 | { count number of occurences of each letter } 19 | // count:=makearray('a','z',0); // for simple 20 | for i:=1 to high(deadbeef) do 21 | begin 22 | c:=deadbeef[i]; 23 | count[c]:=count[c]+1; 24 | end; 25 | { print counts } 26 | for c:='a' to 'f' do 27 | begin 28 | write(c,': ',count[c]); 29 | writeln; 30 | end; 31 | end. 32 | -------------------------------------------------------------------------------- /minipascal/tests-basic/negative-constants.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests negative constants } 3 | program negativeconstants; 4 | const 5 | c=42; 6 | begin 7 | writeln(-12,-c); 8 | end. 9 | -------------------------------------------------------------------------------- /minipascal/tests-basic/negative-index-range.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test if signs in index-ranges work. 3 | Expected: 42} 4 | program indexrange; 5 | const 6 | min=10; 7 | type 8 | negrange = -min..-1; 9 | var 10 | a:array [-min..-1] of integer; 11 | begin 12 | a[-4]:=42; 13 | writeln(a[-4]); 14 | end. 15 | -------------------------------------------------------------------------------- /minipascal/tests-basic/relational-operators.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test the various relational operators. 3 | Expected: true, true } 4 | 5 | program relational; 6 | var 7 | x:boolean; 8 | begin 9 | writeln( (1<2) and (3>2) and (3<>2) 10 | and (3>=2) and (2<=3) and (3=3)); 11 | 12 | writeln( ('a'<'b') and ('c'>'b') and ('c'<>'b') 13 | and ('c'>='b') and ('a'<='b') and ('a'='a') ); 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /minipascal/tests-basic/stdlib-chr.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests chr, which converts bytes to characters.} 3 | Expected result: abc } 4 | program chrtest; 5 | begin 6 | write(chr(97),chr(98),chr(99)); 7 | end. 8 | -------------------------------------------------------------------------------- /minipascal/tests-basic/type-definitions1.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests type definitions equivalent to base types.} 3 | { Expected result: a,1,true } 4 | program types; 5 | type 6 | ch=char; 7 | int=integer; 8 | bool=boolean; 9 | var 10 | c:ch; 11 | i:int; 12 | b:bool; 13 | begin 14 | c:='a'; 15 | i:=1; 16 | b:=true; 17 | writeln(c,i,b); 18 | end. 19 | 20 | -------------------------------------------------------------------------------- /minipascal/tests-basic/type-definitions2.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests type definitions equivalent to array of base type.} 3 | { Expected result: 42 } 4 | program types; 5 | type 6 | int=integer; 7 | arr = array[1..10] of int; 8 | ints = arr; 9 | var 10 | a:ints; 11 | begin 12 | a[3]:=42; 13 | writeln(a[3]); 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /minipascal/tests-fpc/fpc-test.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal simple (input "abcdef") 2 | program fpctest; 3 | var s:string; 4 | begin 5 | writeln('Enter string:'); 6 | readln(s); 7 | writeln('You wrote:'); 8 | writeln(s); 9 | end. 10 | -------------------------------------------------------------------------------- /minipascal/tests-medium/array-of-char.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: The array A is filled with the 'a'..'e'. 3 | The the numbers are printed. 4 | Expected result: abcde } 5 | program bar; 6 | type 7 | CharArray = array[1..5] of char; 8 | var 9 | A:CharArray; 10 | i:integer; 11 | begin 12 | {makerarray is only needed for "compiler-simple.rkt"} 13 | // A:=makearray(1,5,'a'); 14 | {Fill array} 15 | A[1]:='a'; 16 | A[2]:='b'; 17 | A[3]:='c'; 18 | A[4]:='d'; 19 | A[5]:='e'; 20 | {Print elements in array} 21 | i:=1; 22 | while i<6 do 23 | begin 24 | write(A[i]); 25 | i:=i+1; 26 | end; 27 | writeln(' '); 28 | end. 29 | -------------------------------------------------------------------------------- /minipascal/tests-medium/array-of-integer.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: The array A is filled with the numbers 1..10. 3 | The the numbers are summed. Expected result: 55} 4 | program bar; 5 | type 6 | IntArray = array[1..10] of integer; 7 | var 8 | A : IntArray; 9 | i,sum: integer; 10 | begin 11 | {makerarray is only needed for "compiler-simple.rkt"} 12 | // A:=makearray(1,10,0); 13 | {Fill array} 14 | i:=1; 15 | while i<11 do 16 | begin 17 | A[i]:=i; 18 | i:=i+1; 19 | end; 20 | {Sum elements in array} 21 | sum:=0; 22 | i:=1; 23 | while i<11 do 24 | begin 25 | sum:=sum+A[i]; 26 | i:=i+1; 27 | end; 28 | {Print result} 29 | writeln(sum); 30 | end. 31 | -------------------------------------------------------------------------------- /minipascal/tests-medium/array-with-char-index.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: The array A is filled with the 'a'..'e'. 3 | The the numbers are printed. 4 | Expected result: abcde } 5 | program bar; 6 | type 7 | CharArray = array['f'..'j'] of char; 8 | var 9 | A:CharArray; 10 | begin 11 | {makerarray is only needed for "compiler-simple.rkt"} 12 | { A:=makearray('f','j','a'); } 13 | {Fill array} 14 | A['f']:='a'; 15 | A['g']:='b'; 16 | A['h']:='c'; 17 | A['i']:='d'; 18 | A['j']:='e'; 19 | {Print elements in array} 20 | write(A['f']); 21 | write(A['g']); 22 | write(A['h']); 23 | write(A['i']); 24 | write(A['j']); 25 | writeln; 26 | end. 27 | -------------------------------------------------------------------------------- /minipascal/tests-medium/function-with-no-arguments.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: Functions with no arguments. 3 | This program computes the sum 1+2+...+10 = 55. } 4 | program bar; 5 | var 6 | x:integer; 7 | function f:integer; 8 | begin 9 | if x<>0 then 10 | begin 11 | x:=x-1; 12 | f:=x+f; 13 | end 14 | else 15 | f:=x; 16 | end; 17 | begin 18 | x:=11; 19 | writeln(f); 20 | end. 21 | -------------------------------------------------------------------------------- /minipascal/tests-medium/function-with-one-argument.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: Functions with one arguments. 3 | This program computes the sum 1+2+...+10 = 55. } 4 | program bar; 5 | var 6 | sum:integer; 7 | function f(x:integer):integer; 8 | begin 9 | if x<>0 then 10 | begin 11 | sum:=sum+x; 12 | f(x-1); 13 | end 14 | else 15 | f:=sum; 16 | end; 17 | begin 18 | sum:=0; 19 | writeln(f(10)); 20 | end. 21 | -------------------------------------------------------------------------------- /minipascal/tests-medium/function-with-two-arguments.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: Functions with two arguments. 3 | This program computes the sum 1+2+...+10 = 55. } 4 | program bar; 5 | function f(sum,x:integer):integer; 6 | begin 7 | if x<>0 then 8 | begin 9 | f(sum+x,x-1); 10 | end 11 | else 12 | f:=sum; 13 | end; 14 | begin 15 | writeln(f(0,10)); 16 | end. 17 | -------------------------------------------------------------------------------- /minipascal/tests-medium/hcf.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | program hcf; 3 | { Highest common factor. 4 | Expeced result: 4 } 5 | var 6 | r:integer; 7 | 8 | function mod(x,y:integer):integer; 9 | begin 10 | mod := x-(x div y)*y; 11 | end; 12 | 13 | function hcf(p,q:integer):integer; 14 | begin 15 | r:=mod(p,q); 16 | while r<>0 do 17 | begin 18 | p:=q; 19 | q:=r; 20 | r:=mod(p,q); 21 | end; 22 | hcf:=q; 23 | end; 24 | begin 25 | hcf(2*2*3,2*2*5); 26 | end. 27 | -------------------------------------------------------------------------------- /minipascal/tests-medium/horner.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Tests whether a formal parameter shadows 3 | a constant declaration in the body of a function, 4 | and that the constant is back in scope afterwards. } 5 | { Expected result: 17,17 } 6 | 7 | program horner; 8 | const 9 | n=2; 10 | type 11 | natural=integer; 12 | ring=integer; 13 | coefs=array[0..n] of ring; 14 | var 15 | poly:coefs; 16 | 17 | function horner(a:coefs; x:ring; n:natural):ring; 18 | var y:ring; i:natural; 19 | begin 20 | y:=0; 21 | for i:=0 to n do 22 | y:=y*x+a[i]; 23 | horner:=y; 24 | end; 25 | 26 | begin 27 | { poly:=makearray(0,2,0); // For simple } 28 | poly[0]:=3; 29 | poly[1]:=2; 30 | poly[2]:=1; 31 | writeln(horner(poly, 2, n)); 32 | writeln(3*2*2 + 2*2 + 1); 33 | end. 34 | -------------------------------------------------------------------------------- /minipascal/tests-medium/nested-functions.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { This test demonstrates nested functions. 3 | The expected result is 7. 4 | Original examples from Wikipedia.} 5 | program nested; 6 | type 7 | int=integer; 8 | var 9 | n:integer; 10 | function E(x: int): int; 11 | function F(y: int): int; 12 | begin 13 | F := x + y 14 | end; 15 | begin 16 | E := F(3) + F(2) 17 | end; 18 | begin 19 | writeln(E(1)); 20 | end. 21 | -------------------------------------------------------------------------------- /minipascal/tests-medium/procedure-with-no-arguments.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: Procedures with no arguments. 3 | This program computes the sum 1+2+...+10 = 55. } 4 | program bar; 5 | var 6 | sum,x: integer; 7 | procedure f; 8 | begin 9 | if x<>0 then 10 | begin 11 | sum:=sum+x; 12 | x:=x-1; 13 | f; 14 | end; 15 | end; 16 | begin 17 | sum:=0; 18 | x:=10; 19 | f; 20 | writeln(sum); 21 | end. 22 | -------------------------------------------------------------------------------- /minipascal/tests-medium/procedure-with-two-arguments.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | { Test: Procedures with two arguments. 3 | This program computes the sum 1+2+...+10 = 55. } 4 | program bar; 5 | var 6 | result:integer; 7 | 8 | procedure f(sum,x:integer); 9 | begin 10 | if x<>0 then 11 | begin 12 | f(sum+x,x-1); 13 | end 14 | else 15 | result:=sum; 16 | end; 17 | 18 | begin 19 | result:=0; 20 | f(0,10); 21 | writeln(result); 22 | end. 23 | -------------------------------------------------------------------------------- /minipascal/tests-medium/strings.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | program strings; 3 | var 4 | s,t,u,v: String; 5 | begin 6 | s:='Hello world!'; 7 | t:='Hello world!'; 8 | u:='Hello worle!'; 9 | v:='Hello worlc!'; 10 | // write('length of s: '); 11 | // writeln(length(s)); 12 | 13 | writeln('These comparisons are all true:'); 14 | writeln(s=t); 15 | writeln(sv); 17 | writeln(s<=t); 18 | writeln(s<=u); 19 | writeln(s>=v); 20 | writeln(s<>u); 21 | end. 22 | -------------------------------------------------------------------------------- /minipascal/tests-medium/write-natural.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | program WriteNatural; 3 | 4 | function mod(x,y:integer):integer; 5 | begin 6 | mod:=x-(x div y)*y; 7 | end; 8 | 9 | procedure WriteNatural(i:integer); 10 | begin 11 | if i<10 then 12 | write(chr(i+ord('0'))) 13 | else 14 | begin 15 | WriteNatural(i div 10); 16 | write(chr(mod(i,10)+ord('0'))); 17 | end 18 | end; 19 | begin 20 | WriteNatural(12345); 21 | end. 22 | 23 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG021.PAS: -------------------------------------------------------------------------------- 1 | program ALG021; 2 | { BISECTION ALGORITHM 2.1 3 | 4 | To find a solution to f(x) = 0 given the continuous function 5 | f on the interval [a,b], where f(a) and f(b) have 6 | opposite signs: 7 | 8 | INPUT: endpoints a,b; tolerance TOL; 9 | maximum number of iterations N0. 10 | 11 | OUTPUT: approximate solution p or 12 | a message that the algorithm fails. 13 | 14 | } 15 | const ZERO = 1.0E-20; 16 | var 17 | A,FA,B,FB,C,P,FP,TOL,X : real; 18 | I,N0,FLAG : integer; 19 | OK : boolean; 20 | AA : char; 21 | OUP : text; 22 | NAME : string [ 30 ]; 23 | { Change function F for a new problem } 24 | function F ( X : real ) : real; 25 | begin 26 | F := ( X + 4.0 ) * X * X - 10.0 27 | end; 28 | procedure INPUT; 29 | begin 30 | writeln('This is the Bisection Method.'); 31 | write ('Has the function F been created in the program '); 32 | writeln ('immediately preceding '); 33 | writeln ('the INPUT procedure? '); 34 | writeln ('Enter Y or N '); 35 | readln ( AA ); 36 | if ( AA = 'Y' ) or ( AA = 'y' ) then 37 | begin 38 | OK := false; 39 | while ( not OK ) do 40 | begin 41 | writeln ('Input endpoints A < B separated by blank '); 42 | readln ( A , B ); 43 | if ( A > B ) then 44 | begin 45 | X := A; A := B; B := X 46 | end; 47 | if ( A = B ) then writeln ('A cannot equal B ') 48 | else 49 | begin 50 | FA := F( A ); 51 | FB := F( B ); 52 | if ( FA * FB > 0.0 ) then 53 | writeln ('F(A) and F(B) have same sign ') 54 | else OK := true 55 | end 56 | end; 57 | OK := false; 58 | while ( not OK ) do 59 | begin 60 | writeln ('Input tolerance '); 61 | readln ( TOL ); 62 | if (TOL <= 0.0) then writeln ('Tolerance must be positive ') 63 | else OK := true 64 | end; 65 | OK := false; 66 | while ( not OK ) do 67 | begin 68 | write('Input maximum number of iterations '); 69 | writeln('- no decimal point '); 70 | readln ( N0 ); 71 | if ( N0 <= 0 ) then writeln ('Must be positive integer ') 72 | else OK := true 73 | end 74 | end 75 | else 76 | begin 77 | write ('The program will end so that the function F '); 78 | writeln ('can be created '); 79 | OK := false 80 | end 81 | end; 82 | procedure OUTPUT; 83 | begin 84 | writeln ('Select output destination '); 85 | writeln ('1. Screen '); 86 | writeln ('2. Text file '); 87 | writeln ('Enter 1 or 2 '); 88 | readln ( FLAG ); 89 | if ( FLAG = 2 ) then 90 | begin 91 | write ('Input the file name in the form - '); 92 | writeln ('drive:name.ext '); 93 | writeln ('for example: A:OUTPUT.DTA '); 94 | readln ( NAME ); 95 | assign ( OUP, NAME ) 96 | end 97 | else assign ( OUP, 'CON'); 98 | rewrite ( OUP ); 99 | writeln(OUP,'BISECTION METHOD'); 100 | writeln ('Select amount of output '); 101 | writeln ('1. Answer only '); 102 | writeln ('2. All intermediate approximations '); 103 | writeln ('Enter 1 or 2 '); 104 | readln (FLAG); 105 | if FLAG = 2 then 106 | begin 107 | writeln(OUP,'I':3,' ','P':14,' ','F(P)':14) 108 | end 109 | end; 110 | begin 111 | INPUT; 112 | if (OK) then 113 | begin 114 | OUTPUT; 115 | { STEP 1 } 116 | I := 1; 117 | OK := true; 118 | { STEP 2 } 119 | while ( ( I <= N0 ) and OK ) do 120 | begin 121 | { STEP 3 } 122 | { compute P(I) } 123 | C := ( B - A ) / 2.0; 124 | P := A + C; 125 | { STEP 4 } 126 | FP := F( P ); 127 | if (FLAG = 2) then 128 | begin 129 | writeln(OUP,I:3,' ',P:14,' ',FP:14) 130 | end; 131 | if ( abs(FP) < ZERO ) or ( C < TOL ) then 132 | { procedure completed successfully } 133 | begin 134 | writeln(OUP); 135 | writeln (OUP,'Approximate solution P = ',P:12:8 ); 136 | writeln (OUP,'with F(P) = ',FP:12:8 ); 137 | write (OUP,'Number of iterations = ',I:3 ); 138 | writeln (OUP,' Tolerance = ',TOL:14 ); 139 | OK := false 140 | end 141 | else 142 | begin 143 | { STEP 5 } 144 | I := I + 1; 145 | { STEP 6 } 146 | { compute A(I) and B(I) } 147 | if ( FA * FP > 0.0 ) then 148 | begin 149 | A := P; FA := FP 150 | end 151 | else 152 | begin 153 | B := P; FB := FP 154 | end 155 | end 156 | end; 157 | if OK then 158 | { STEP 7 } 159 | { procedure completed unsuccessfully } 160 | begin 161 | writeln(OUP); 162 | write (OUP,'Iteration number ',N0:3); 163 | writeln(OUP,' gave approximation ',P:12:8 ); 164 | writeln (OUP,'F(P) = ',FP:12:8,' not within tolerance : ',TOL:14 ) 165 | end; 166 | close(OUP); 167 | end 168 | end. 169 | 170 | 171 | 172 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG022.PAS: -------------------------------------------------------------------------------- 1 | program ALGO22; 2 | { FIXED-POINT ALGORITHM 2.2 3 | 4 | To find a solution to p = g(p) given an 5 | initial approximation p0: 6 | 7 | INPUT: initial approximation p0; tolerance TOL; 8 | maximum number of iterations N0. 9 | 10 | OUTPUT: approximate solution p or 11 | a message that the method fails. 12 | } 13 | var 14 | TOL,P0,P : real; 15 | I,N0,FLAG : integer; 16 | OK : boolean; 17 | AA : char; 18 | OUP : text; 19 | NAME : string [ 30 ]; 20 | { Change function G for a new problem } 21 | function G ( X : real ) : real; 22 | begin 23 | G := sqrt( 10.0 / ( 4.0 + X ) ) 24 | end; 25 | procedure INPUT; 26 | begin 27 | writeln('This is the Fixed-Point Method.'); 28 | write ('Has the function G been created in the program '); 29 | writeln ('immediately preceding '); 30 | writeln ('the INPUT procedure? '); 31 | writeln ('Enter Y or N '); 32 | readln ( AA ); 33 | if ( AA = 'Y' ) or ( AA = 'y' ) then 34 | begin 35 | OK := false; 36 | writeln ('Input initial approximation '); 37 | readln ( P0 ); 38 | while ( not OK ) do 39 | begin 40 | writeln ('Input tolerance '); 41 | readln ( TOL ); 42 | if ( TOL <= 0.0 ) then writeln ('Tolerance must be positve ') 43 | else OK := true 44 | end; 45 | OK := false; 46 | while ( not OK ) do 47 | begin 48 | write('Input maximum number of iterations'); 49 | writeln(' - no decimal point '); 50 | readln ( N0 ); 51 | if ( N0 <= 0 ) then writeln ('Must be positive integer ') 52 | else OK := true 53 | end 54 | end 55 | else 56 | begin 57 | write ('The program will end so that the function G '); 58 | writeln ('can be created '); 59 | OK := false 60 | end 61 | end; 62 | procedure OUTPUT; 63 | begin 64 | writeln ('Select output destination '); 65 | writeln ('1. Screen '); 66 | writeln ('2. Text file '); 67 | writeln ('Enter 1 or 2 '); 68 | readln ( FLAG ); 69 | if ( FLAG = 2 ) then 70 | begin 71 | write ('Input the file name in the form - '); 72 | writeln ('drive:name.ext '); 73 | writeln ('for example: A:OUTPUT.DTA '); 74 | readln ( NAME ); 75 | assign ( OUP, NAME ) 76 | end 77 | else assign ( OUP, 'CON'); 78 | rewrite ( OUP ); 79 | writeln ('Select amount of output '); 80 | writeln ('1. Answer only '); 81 | writeln ('2. All intermediate approximations '); 82 | writeln ('Enter 1 or 2 '); 83 | readln (FLAG); 84 | writeln(OUP,'FIXED-POINT METHOD'); 85 | if FLAG = 2 then 86 | begin 87 | writeln(OUP,'I':3,' ','P':14) 88 | end 89 | end; 90 | begin 91 | INPUT; 92 | if (OK) then 93 | begin 94 | OUTPUT; 95 | { STEP 1 } 96 | I := 1; OK := true; 97 | { STEP 2 } 98 | while ( ( I <= N0 ) and OK ) do 99 | begin 100 | { STEP 3 } 101 | { compute P(I) } 102 | P := G( P0 ); 103 | if (FLAG = 2) then 104 | begin 105 | writeln(OUP,I:3,' ',P:14) 106 | end; 107 | { STEP 4 } 108 | if ( abs( P - P0 ) < TOL ) then 109 | { procedure completed successfully } 110 | begin 111 | writeln (OUP); 112 | writeln (OUP,'Approximate solution P = ',P:12:8 ); 113 | write (OUP,'Number of iterations = ',I:3 ); 114 | writeln (OUP,' Tolerance = ',TOL:14 ); 115 | OK := false 116 | end 117 | else 118 | begin 119 | { STEP 5 } 120 | I := I + 1; 121 | { STEP 6 } 122 | { update P0 } 123 | P0 := P 124 | end 125 | end; 126 | if OK then 127 | { STEP 7 } 128 | { procedure completed unsuccessfully } 129 | begin 130 | write(OUP,'Iteration number ',N0:3); 131 | writeln(OUP,' gave approximation ',P:12:8 ); 132 | writeln (OUP,'not within tolerance ',TOL:14 ) 133 | end; 134 | close(OUP); 135 | end 136 | end. 137 | 138 | 139 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG023.PAS: -------------------------------------------------------------------------------- 1 | program ALG023; 2 | { NEWTON-RAPHSON ALGORITHM 2.3 3 | 4 | To find a solution to f(x) = 0 given an 5 | initial approximation p0: 6 | 7 | INPUT: initial approximation p0; tolerance TOL; 8 | maximum number of iterations NO. 9 | 10 | OUTPUT: approximate solution p or 11 | a message that the algorithm fails. 12 | } 13 | var 14 | TOL,P0,D,P,F0,FP0 : real; 15 | I,N0,FLAG : integer; 16 | OK : boolean; 17 | AA : char; 18 | OUP : text; 19 | NAME : string [ 30 ]; 20 | { Change functions F and FP for a new problem } 21 | function F(X : real) : real; 22 | begin 23 | F := cos(X) - X 24 | end; 25 | { FP is the derivative of F } 26 | function FP ( X : real ) : real; 27 | begin 28 | FP := -sin(X) - 1 29 | end; 30 | procedure INPUT; 31 | begin 32 | writeln('This is Newtons Method'); 33 | write ('Have the functions F and F'' been created in the program '); 34 | writeln ('immediately preceding '); 35 | writeln ('the INPUT procedure? '); 36 | writeln ('Enter Y or N '); 37 | readln ( AA ); 38 | if ( AA = 'Y' ) or ( AA = 'y' ) then 39 | begin 40 | OK := false; 41 | writeln ('Input initial approximation '); 42 | readln ( P0 ); 43 | while ( not OK ) do 44 | begin 45 | writeln ('Input tolerance '); 46 | readln ( TOL ); 47 | if (TOL <= 0.0) then writeln ('Tolerance must be positive ') 48 | else OK := true 49 | end; 50 | OK := false; 51 | while ( not OK ) do 52 | begin 53 | write('Input maximum number of iterations'); 54 | writeln(' - no decimal point '); 55 | readln ( N0 ); 56 | if ( N0 <= 0 ) then writeln ('Must be positive integer ') 57 | else OK := true 58 | end 59 | end 60 | else 61 | begin 62 | write ('The program will end so that the functions F and F'' '); 63 | writeln ('can be created '); 64 | OK := false 65 | end 66 | end; 67 | procedure OUTPUT; 68 | begin 69 | writeln ('Select output destination '); 70 | writeln ('1. Screen '); 71 | writeln ('2. Text file '); 72 | writeln ('Enter 1 or 2 '); 73 | readln ( FLAG ); 74 | if ( FLAG = 2 ) then 75 | begin 76 | write ('Input the file name in the form - '); 77 | writeln ('drive:name.ext '); 78 | writeln ('for example: A:OUTPUT.DTA '); 79 | readln ( NAME ); 80 | assign ( OUP, NAME ) 81 | end 82 | else assign ( OUP, 'CON'); 83 | rewrite ( OUP ); 84 | writeln(OUP,'NEWTONS METHOD'); 85 | writeln ('Select amount of output '); 86 | writeln ('1. Answer only '); 87 | writeln ('2. All intermediate approximations '); 88 | writeln ('Enter 1 or 2 '); 89 | readln (FLAG); 90 | if FLAG = 2 then 91 | begin 92 | writeln(OUP,'I':3,' ','P':14,' ','F(P)':14) 93 | end 94 | end; 95 | begin 96 | INPUT; 97 | if (OK) then 98 | begin 99 | OUTPUT; 100 | F0 := F( P0 ); 101 | { STEP 1 } 102 | I := 1; OK := true; 103 | { STEP 2 } 104 | while ( ( I <= N0 ) and OK ) do 105 | begin 106 | { STEP 3 } 107 | { compute P(I) } 108 | FP0 := FP( P0 ); 109 | D := F0 / FP0; 110 | { STEP 6 } 111 | P0 := P0 - D; 112 | F0 := F( P0 ); 113 | if (FLAG = 2) then 114 | begin 115 | writeln(OUP,I:3,' ',P0:14,' ',F0:14) 116 | end; 117 | { STEP 4 } 118 | if ( abs( D ) < TOL ) then 119 | { procedure completed successfully } 120 | begin 121 | writeln (OUP); 122 | writeln (OUP,'Approximate solution = ',P0 ); 123 | writeln (OUP,'with F(P) = ',F0 ); 124 | writeln (OUP,'Number of iterations = ',I ); 125 | writeln (OUP,'Tolerance = ',TOL ); 126 | OK := false 127 | end 128 | else 129 | { STEP 5 } 130 | I := I + 1; 131 | end; 132 | if OK then 133 | begin 134 | { STEP 7 } 135 | { procedure completed unsuccessfully } 136 | writeln (OUP,'Iteration number ',N0, 137 | ' gave approximation ',P0 ); 138 | writeln (OUP,'with F(P) = ',F0,' not within tolerance ',TOL ) 139 | end; 140 | close(OUP); 141 | end 142 | end. 143 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG024.PAS: -------------------------------------------------------------------------------- 1 | program ALG024; 2 | { SECANT ALGORITHM 2.4 3 | 4 | To find a solution to the equation f(x) = 0 5 | given initial approximations p0 and p1: 6 | 7 | INPUT: initial approximations p0, p1; tolerance TOL; 8 | maximum number of iterations N0. 9 | 10 | OUTPUT: approximate solution p or 11 | a message that the algorithm fails. 12 | } 13 | var 14 | P0,F0,P1,F1,P,FP,TOL : real; 15 | I,N0,FLAG : integer; 16 | OK : boolean; 17 | AA : char; 18 | OUP : text; 19 | NAME : string [ 30 ]; 20 | { Change function F for a new problem } 21 | function F ( X : real ) : real; 22 | begin 23 | F := cos( X ) - X 24 | end; 25 | procedure INPUT; 26 | begin 27 | writeln('This is the Secant Method.'); 28 | write ('Has the function F been created in the program '); 29 | writeln ('immediately preceding '); 30 | writeln ('the INPUT procedure? '); 31 | writeln ('Enter Y or N '); 32 | readln ( AA ); 33 | if ( AA = 'Y' ) or ( AA = 'y' ) then 34 | begin 35 | OK := false; 36 | while ( not OK ) do 37 | begin 38 | write ('Input initial approximations P0 and P1 separated '); 39 | writeln ('by blank '); 40 | readln ( P0 , P1 ); 41 | if ( P0 = P1 ) then writeln ('P0 cannot equal P1 ') 42 | else OK := true 43 | end; 44 | OK := false; 45 | while ( not OK ) do 46 | begin 47 | writeln ('Input tolerance '); 48 | readln ( TOL ); 49 | if (TOL <= 0.0) then writeln ('Tolerance must be positive ') 50 | else OK := true 51 | end; 52 | OK := false; 53 | while ( not OK ) do 54 | begin 55 | write('Input maximum number of iterations'); 56 | writeln(' - no decimal point '); 57 | readln ( N0 ); 58 | if ( N0 <= 0 ) then writeln ('Must be positive integer ') 59 | else OK := true 60 | end 61 | end 62 | else 63 | begin 64 | write ('The program will end so that the function F '); 65 | writeln ('can be created '); 66 | OK := false 67 | end 68 | end; 69 | procedure OUTPUT; 70 | begin 71 | writeln ('Select output destination '); 72 | writeln ('1. Screen '); 73 | writeln ('2. Text file '); 74 | writeln ('Enter 1 or 2 '); 75 | readln ( FLAG ); 76 | if ( FLAG = 2 ) then 77 | begin 78 | write ('Input the file name in the form - '); 79 | writeln ('drive:name.ext '); 80 | writeln ('for example: A:OUTPUT.DTA '); 81 | readln ( NAME ); 82 | assign ( OUP, NAME ) 83 | end 84 | else assign ( OUP, 'CON'); 85 | rewrite ( OUP ); 86 | writeln(OUP,'SECANT METHOD'); 87 | writeln ('Select amount of output '); 88 | writeln ('1. Answer only '); 89 | writeln ('2. All intermediate approximations '); 90 | writeln ('Enter 1 or 2 '); 91 | readln (FLAG); 92 | if FLAG = 2 then 93 | begin 94 | writeln(OUP,'I':3,' ','P':14,' ','F(P)':14) 95 | end; 96 | end; 97 | begin 98 | INPUT; 99 | if (OK) then 100 | begin 101 | OUTPUT; 102 | { STEP 1 } 103 | I := 2; 104 | F0 := F( P0 ); 105 | F1 := F( P1 ); 106 | OK := true; 107 | { STEP 2 } 108 | while ( ( I <= N0 ) and OK ) do 109 | begin 110 | { STEP 3 } 111 | { compute P(I) } 112 | P := P1 - F1 * ( P1 - P0 ) / ( F1 - F0 ); 113 | { STEP 4 } 114 | FP := F( P ); 115 | if (FLAG = 2) then 116 | begin 117 | writeln(OUP,I:3,' ',P:14,' ',FP:14) 118 | end; 119 | if ( abs( P - P1 ) < TOL ) then 120 | { procedure completed successfully } 121 | begin 122 | writeln (OUP); 123 | writeln (OUP,'Approximate solution = ',P:12:8 ); 124 | writeln (OUP,'with F(P) =', FP:12:8 ); 125 | write (OUP,'Number of iterations = ',I:3 ); 126 | writeln (OUP,' Tolerance = ',TOL:14 ); 127 | OK := false 128 | end 129 | else 130 | begin 131 | { STEP 5 } 132 | I := I + 1; 133 | { STEP 6 } 134 | { update P0, F0, P1, F1 } 135 | P0 := P1; 136 | F0 := F1; 137 | P1 := P; 138 | F1 := FP 139 | end 140 | end; 141 | if OK then 142 | { STEP 7 } 143 | { procedure completed unsuccessfully } 144 | begin 145 | writeln(OUP); 146 | write(OUP,'Iteration number ',N0:3); 147 | writeln(OUP,' gave approximation ',P:12:8 ); 148 | writeln (OUP,'F(P) = ',FP:12:8, 149 | ' not within tolerance : ',TOL:14 ) 150 | end; 151 | close(OUP); 152 | end 153 | end. 154 | 155 | 156 | 157 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG025.PAS: -------------------------------------------------------------------------------- 1 | program ALG025; 2 | { METHOD OF FALSE POSITION ALGORITHM 2.5 3 | 4 | To find a solution to f(x) = 0 given the continuous function 5 | f on the interval [p0,p1], where f(p0) and f(p1) have 6 | opposite signs: 7 | 8 | INPUT: endpoints p0, p1; tolerance TOL; 9 | maximum number of iterations N0. 10 | 11 | OUTPUT: approximate solution p or 12 | a message that the algorithm fails. 13 | 14 | } 15 | const ZERO = 1.0E-20; 16 | var 17 | Q,P0,Q0,P1,Q1,C,P,FP,TOL,X : real; 18 | I,N0 : integer; 19 | OK : boolean; 20 | AA : char; 21 | OUP : text; 22 | FLAG : integer; 23 | NAME : string [ 30 ]; 24 | { Change function F for a new problem. } 25 | function F ( X : real ) : real; 26 | begin 27 | F := cos(X) - X 28 | end; 29 | procedure INPUT; 30 | begin 31 | writeln('This is the Method of False Position.'); 32 | write ('Has the function F been created in the program '); 33 | writeln ('immediately preceding '); 34 | writeln ('the INPUT procedure? '); 35 | writeln ('Enter Y or N. '); 36 | readln ( AA ); 37 | if ( AA = 'Y' ) or ( AA = 'y' ) then 38 | begin 39 | OK := false; 40 | while ( not OK ) do 41 | begin 42 | writeln ('Input endpoints P0 < P1 separated by blank. '); 43 | readln ( P0 , P1 ); 44 | if ( P0 > P1 ) then 45 | begin 46 | X := P0; P0 := P1; P1 := X 47 | end; 48 | if ( P0 = P1 ) then writeln ('P0 cannot equal P1. ') 49 | else 50 | begin 51 | Q0 := F( P0 ); 52 | Q1 := F( P1 ); 53 | if ( Q0 * Q1 > 0.0 ) then 54 | writeln ('F(P0) and F(P1) have same sign. ') 55 | else OK := true 56 | end 57 | end; 58 | OK := false; 59 | while ( not OK ) do 60 | begin 61 | writeln ('Input tolerance. '); 62 | readln ( TOL ); 63 | if (TOL <= 0.0) then writeln ('Tolerance must be positive. ') 64 | else OK := true 65 | end; 66 | OK := false; 67 | while ( not OK ) do 68 | begin 69 | write('Input maximum number of iterations '); 70 | writeln('- no decimal point. '); 71 | readln ( N0 ); 72 | if ( N0 <= 0 ) then writeln ('Must be positive integer. ') 73 | else OK := true 74 | end 75 | end 76 | else 77 | begin 78 | write ('The program will end so that the function F '); 79 | writeln ('can be created. '); 80 | OK := false 81 | end 82 | end; 83 | procedure OUTPUT; 84 | begin 85 | writeln ('Choice of output method: '); 86 | writeln ('1. Output to screen '); 87 | writeln ('2. Output to text file '); 88 | writeln ('Please enter 1 or 2 '); 89 | readln ( FLAG ); 90 | if ( FLAG = 2 ) then 91 | begin 92 | writeln ('Input the file name in the form - drive:name.ext '); 93 | readln ( NAME ); 94 | assign ( OUP, NAME ) 95 | end 96 | else assign ( OUP, 'CON' ); 97 | writeln ('Select amount of output '); 98 | writeln ('1. Answer only '); 99 | writeln ('2. All intermediate approximations '); 100 | writeln ('Enter 1 or 2 '); 101 | readln (FLAG); 102 | rewrite ( OUP ); 103 | writeln(OUP,'METHOD OF FALSE POSITION OR REGULA FALSII'); 104 | writeln ( OUP ); 105 | if FLAG = 2 then 106 | begin 107 | writeln(OUP,'I':3,' ','P':14,' ','F(P)':14) 108 | end 109 | end; 110 | begin 111 | INPUT; 112 | if (OK) then 113 | begin 114 | { STEP 1 } 115 | OUTPUT; 116 | I := 2; 117 | OK := true; 118 | Q0 := F( P0 ); 119 | Q1 := F( P1 ); 120 | { STEP 2 } 121 | while ( ( I <= N0 ) and OK ) do 122 | begin 123 | { STEP 3 } 124 | { compute P(I) } 125 | P := P1 - Q1 * ( P1 - P0 ) / ( Q1 - Q0 ); 126 | Q := F( P ); 127 | if (FLAG = 2) then 128 | begin 129 | writeln(OUP,I:3,' ',P:14,' ',Q:14) 130 | end; 131 | { STEP 4 } 132 | if ( abs(P-P1) < TOL ) then 133 | begin 134 | { Procedure completed successfully. } 135 | writeln (OUP); 136 | writeln (OUP,'Approximate solution P = ',P:12:8 ); 137 | writeln (OUP,'with F(P) = ',Q:12:8 ); 138 | write (OUP,'Number of iterations = ',I:3 ); 139 | writeln (OUP,' Tolerance = ',TOL:14 ); 140 | OK := false 141 | end 142 | else 143 | begin 144 | { STEP 5 } 145 | I := I + 1; 146 | { STEP 6 } 147 | { compute P0(I) and P1(I) } 148 | if ( Q * Q1 < 0.0 ) then 149 | begin 150 | P0 := P1; Q0 := Q1 151 | end; 152 | { STEP 7 } 153 | P1 := P; Q1 := Q; 154 | end 155 | end; 156 | if OK then 157 | { STEP 8 } 158 | { procedure completed unsuccessfully } 159 | begin 160 | writeln(OUP); 161 | write(OUP,'Iteration number ',N0:3); 162 | writeln(OUP,' gave approximation ',P:12:8 ); 163 | writeln (OUP,'F(P) = ',Q:12:8, 164 | ' not within tolerance : ',TOL:14 ); 165 | writeln('failed'); 166 | end; 167 | close(OUP) 168 | end 169 | end. 170 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG026.PAS: -------------------------------------------------------------------------------- 1 | program ALGO26; 2 | { STEFFENSEN'S ALGORITHM 2.6 3 | 4 | To find a solution to g(x) = x 5 | given an initial approximation p0: 6 | 7 | INPUT: initial approximation p0; tolerance TOL; 8 | maximum number of iterations N0. 9 | 10 | OUTPUT: approximate solution p or 11 | a message that the method fails. 12 | } 13 | var 14 | TOL,P0,P1,P2,P,D,ZERO : real; 15 | I,N0,FLAG : integer; 16 | OK : boolean; 17 | AA : char; 18 | OUP : text; 19 | NAME : string [ 30 ]; 20 | { Change function G for a new problem } 21 | function G ( X : real ) : real; 22 | begin 23 | G := sqrt( 10.0 / ( 4.0 + X ) ) 24 | end; 25 | procedure INPUT; 26 | begin 27 | writeln('This is Steffensens Method.'); 28 | write ('Has the function G been created in the program '); 29 | writeln ('immediately preceding '); 30 | writeln ('the INPUT procedure? '); 31 | writeln ('Enter Y or N '); 32 | readln ( AA ); 33 | if ( AA = 'Y' ) or ( AA = 'y' ) then 34 | begin 35 | OK := false; 36 | writeln ('Input initial approximation '); 37 | readln ( P0 ); 38 | while ( not OK ) do 39 | begin 40 | writeln ('Input tolerance '); 41 | readln ( TOL ); 42 | if ( TOL <= 0.0 ) then writeln ('Tolerance must be positve ') 43 | else OK := true 44 | end; 45 | OK := false; 46 | while ( not OK ) do 47 | begin 48 | write('Input maximum number of iterations'); 49 | writeln(' - no decimal point '); 50 | readln ( N0 ); 51 | if ( N0 <= 0 ) then writeln ('Must be positive integer ') 52 | else OK := true 53 | end 54 | end 55 | else 56 | begin 57 | write ('The program will end so that the function G '); 58 | writeln ('can be created '); 59 | OK := false 60 | end 61 | end; 62 | procedure OUTPUT; 63 | begin 64 | writeln ('Select output destination '); 65 | writeln ('1. Screen '); 66 | writeln ('2. Text file '); 67 | writeln ('Enter 1 or 2 '); 68 | readln ( FLAG ); 69 | if ( FLAG = 2 ) then 70 | begin 71 | write ('Input the file name in the form - '); 72 | writeln ('drive:name.ext '); 73 | writeln ('for example: A:OUTPUT.DTA '); 74 | readln ( NAME ); 75 | assign ( OUP, NAME ) 76 | end 77 | else assign ( OUP, 'CON'); 78 | rewrite ( OUP ); 79 | writeln ('Select amount of output '); 80 | writeln ('1. Answer only '); 81 | writeln ('2. All intermediate approximations '); 82 | writeln ('Enter 1 or 2 '); 83 | readln (FLAG); 84 | writeln(OUP,'STEFFENSENS METHOD'); 85 | if FLAG = 2 then 86 | begin 87 | writeln(OUP,'I':3,' ','P':14) 88 | end; 89 | end; 90 | begin 91 | ZERO := 1.0E-20; 92 | INPUT; 93 | if (OK) then 94 | begin 95 | OUTPUT; 96 | { STEP 1 } 97 | I := 1; OK := true; 98 | { STEP 2 } 99 | while ( ( I <= N0 ) and OK ) do 100 | begin 101 | { STEP 3 } 102 | { compute P(1) with superscript ( I - 1 ) } 103 | P1 := G( P0 ); 104 | { compute P(2) with superscript ( I - 1 ) } 105 | P2 := G( P1 ); 106 | if (abs(P2-2.0*P1+P0) < ZERO) then 107 | begin 108 | FLAG := 1; 109 | OK := false; 110 | D := 10.0; 111 | writeln(OUP,'Denominator = 0, method fails'); 112 | writeln(OUP,'best possible is P2(',I,')= ',P2:14) 113 | end 114 | else 115 | D := (P1-P0)*(P1-P0)/(P2-2.0*P1+P0); 116 | { compute P(0) with superscript ( I - 1 ) } 117 | P := P0 - D; 118 | if (FLAG = 2) then 119 | begin 120 | writeln(OUP,I:3,' ',P:14) 121 | end; 122 | { STEP 4 } 123 | if ( abs( D ) < TOL ) then 124 | { procedure completed successfully } 125 | begin 126 | writeln (OUP); 127 | writeln (OUP,'Approximate solution = ',P:12:8 ); 128 | write (OUP,'Number of iterations = ',I:3 ); 129 | writeln (OUP,' Tolerance = ',TOL:14 ); 130 | OK := false 131 | end 132 | else 133 | begin 134 | { STEP 5 } 135 | I := I + 1; 136 | { STEP 6 } 137 | { update P0 } 138 | P0 := P 139 | end 140 | end; 141 | if OK then 142 | { STEP 7 } 143 | { procedure completed unsuccessfully } 144 | begin 145 | writeln(OUP); 146 | write (OUP,'Iteration number ',N0:3); 147 | writeln(OUP,' gave approximation ',P:12:8 ); 148 | writeln (OUP,'not within tolerance ',TOL:14 ) 149 | end; 150 | close(OUP); 151 | end 152 | end. 153 | 154 | 155 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG027.PAS: -------------------------------------------------------------------------------- 1 | program ALG027; 2 | { HORNER'S ALGORITHM 2.7 3 | 4 | To evaluate the polynomial 5 | p(x) = a(n) * x ^ n + a(n-1) * x ^ (n-1) + ... + a(1) * x + a(0) 6 | and its derivative p'(x) at x = x0; 7 | 8 | INPUT: degree n; coefficients aa(0),aa(1),...,aa(n); 9 | value of x0. 10 | 11 | OUTPUT: y = p(x0), z = p'(x0). 12 | } 13 | var 14 | AA : array [ 0 .. 50 ] of real; 15 | X0,Y,Z : real; 16 | N,MM,I,J : integer; 17 | OK : boolean; 18 | procedure INPUT; 19 | begin 20 | writeln('This is Horners Method'); 21 | OK := false; 22 | while ( not OK ) do 23 | begin 24 | writeln ('Input degree n of polynomial - no decimal point '); 25 | readln ( N ); 26 | if ( N < 0 ) then writeln ('Integer N must be nonnegative') 27 | else OK := true 28 | end; 29 | writeln('Input coefficients of P(X) in ascending order.'); 30 | for I := 0 to N do 31 | begin 32 | writeln ('Input coefficient of X^ ',I ); 33 | readln ( AA[I] ) 34 | end; 35 | writeln ('Input argument X0 at which to evaluate P(X)'); 36 | readln ( X0 ) 37 | end; 38 | begin 39 | INPUT; 40 | { STEP 1 } 41 | { compute b(n) for p(x) } 42 | Y := AA[N]; 43 | { compute b(n-1) for q(x) = p'(x) } 44 | if N = 0 then Z := 0 45 | else Z := AA[N]; 46 | MM := N - 1; 47 | { STEP 2 } 48 | for I := 1 to MM do 49 | begin 50 | J := N - I; 51 | { compute b(j) for p(x) } 52 | Y := Y * X0 + AA[J]; 53 | { compute b(j-1) for q(x) } 54 | Z := Z * X0 + Y 55 | end; 56 | { STEP 3 } 57 | { compute b(0) for p(x) } 58 | if (N <> 0) then Y := Y * X0 + AA[0]; 59 | writeln ('Coefficients of polynomial P : '); 60 | { STEP 4 } 61 | for I := 0 to N do 62 | writeln ('Exponent = ',I:3,' Coefficient = ',AA[I]:12:8 ); 63 | writeln (' '); 64 | writeln (' P ( ',X0,' ) = ',Y:12:8 ); 65 | writeln (' P'' ( ',X0,' ) = ',Z:12:8 ) 66 | end. 67 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG041.PAS: -------------------------------------------------------------------------------- 1 | program ALG041; 2 | { SIMPSON'S COMPOSITE ALGORITHM 4.1 3 | 4 | To approximate I = integral ( ( f(x) dx ) ) from a to b: 5 | 6 | INPUT: endpoints a, b; even positive integer n. 7 | 8 | OUTPUT: approximation XI to I. 9 | } 10 | var 11 | A,B,XI0,XI1,XI2,H,XI,X : real; 12 | N,I,NN : integer; 13 | OK : boolean; 14 | AA : char; 15 | { Change function F for a new problem } 16 | function F ( X : real ) : real; 17 | begin 18 | F := sin ( X ) 19 | end; 20 | procedure INPUT; 21 | begin 22 | writeln('This is Simpsons Method.'); 23 | writeln(' '); 24 | write ('Has the function F been created in the program '); 25 | writeln ('immediately preceding '); 26 | writeln ('the INPUT procedure? '); 27 | writeln ('Enter Y or N '); 28 | readln ( AA ); 29 | if ( AA = 'Y' ) or ( AA = 'y' ) then 30 | begin 31 | OK := false; 32 | while ( not OK ) do 33 | begin 34 | write ('Input lower limit of integration and '); 35 | writeln ('upper limit of integration '); 36 | writeln ('separated by a blank '); 37 | readln ( A, B ); 38 | if ( A >= B ) then 39 | begin 40 | write ('Lower limit must be less '); 41 | writeln ('than upper limit ') 42 | end 43 | else OK := true 44 | end; 45 | OK := false; 46 | while ( not OK ) do 47 | begin 48 | writeln ('Input an even positive integer N.'); 49 | readln ( N ); 50 | if ((N > 0) and ((N div 2) * 2 = N)) 51 | then OK := true 52 | else 53 | writeln('Input must be even and positive ') 54 | end 55 | end 56 | else 57 | begin 58 | write ('The program will end so that the function F '); 59 | writeln ('can be created '); 60 | OK := false 61 | end 62 | end; 63 | procedure OUTPUT; 64 | begin 65 | writeln; 66 | writeln ('The integral of F from ',A:12:8,' to ',B:12:8,' is '); 67 | writeln ( XI:12:8 ) 68 | end; 69 | begin 70 | INPUT; 71 | if (OK) then 72 | begin 73 | { STEP 1 } 74 | H := ( B - A ) / N; 75 | { STEP 2 } 76 | XI0 := F( A ) + F( B ); 77 | { summation of f(x(2*I-1)) } 78 | XI1 := 0.0; 79 | { summation of f(x(2*I)) } 80 | XI2 := 0.0; 81 | { STEP 3 } 82 | NN := N - 1; 83 | for I := 1 to NN do 84 | begin 85 | { STEP 4 } 86 | X := A + I * H; 87 | { STEP 5 } 88 | if ( I = I div 2 * 2 ) then XI2 := XI2 + F( X ) 89 | else XI1 := XI1 + F( X ) 90 | end; 91 | { STEP 6 } 92 | XI := ( XI0 + 2.0 * XI2 + 4.0 * XI1 ) * H / 3.0; 93 | { STEP 7 } 94 | OUTPUT 95 | end 96 | end. 97 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG042.PAS: -------------------------------------------------------------------------------- 1 | program ALG042; 2 | { ROMBERG ALGORITHM 4.2 3 | 4 | To approximate I = integral( ( f(x) dx ) ) from a to b: 5 | 6 | INPUT: endpoints a, b; integer n. 7 | 8 | OUTPUT: an array R. ( R(2,n) is the approximation to I. ) 9 | 10 | R is computed by rows; only 2 rows saved in storage } 11 | var 12 | R : array [ 1..2 , 1..15 ] of real; 13 | X,A,B,H,SUM : real; 14 | I,J,K,L,M,N : integer; 15 | OK : boolean; 16 | AA : char; 17 | { Change function F for a new problem } 18 | function F ( X : real ) : real; 19 | begin 20 | F := sin( X ) 21 | end; 22 | procedure INPUT; 23 | begin 24 | writeln('This is Romberg integration.'); 25 | writeln(' '); 26 | write ('Has the function F been created in the program '); 27 | writeln ('immediately preceding '); 28 | writeln ('the INPUT procedure? '); 29 | writeln ('Enter Y or N '); 30 | readln ( AA ); 31 | if ( AA = 'Y' ) or ( AA = 'y' ) then 32 | begin 33 | OK := false; 34 | while ( not OK ) do 35 | begin 36 | write ('Input lower limit of integration and '); 37 | writeln ('upper limit of integration '); 38 | writeln ('separated by a blank '); 39 | readln ( A, B ); 40 | if ( A >= B ) then 41 | begin 42 | write ('Lower limit must be less '); 43 | writeln ('than upper limit ') 44 | end 45 | else OK := true 46 | end; 47 | OK := false; 48 | while ( not OK ) do 49 | begin 50 | writeln ('Input number of rows - no decimal point '); 51 | readln ( N ); 52 | if ( N > 0 ) then OK := true 53 | else writeln ('Number must be a positive integer ') 54 | end 55 | end 56 | else 57 | begin 58 | write ('The program will end so that the function F '); 59 | writeln ('can be created '); 60 | OK := false 61 | end 62 | end; 63 | begin 64 | INPUT; 65 | { STEP 1 } 66 | if (OK) then 67 | begin 68 | H := B - A; 69 | R[1,1] := ( F( A ) + F( B ) ) / 2.0 * H; 70 | { STEP 2 } 71 | writeln ('Initial Data: '); 72 | writeln ('Limits of integration = [',A:12:8,', ',B:12:8,']'); 73 | writeln ('Number of rows = ',N:3 ); 74 | writeln; writeln ('Romberg Integration Table: '); 75 | writeln; writeln ( R[1,1]:12:8 ); writeln; 76 | { STEP 3 } 77 | for I := 2 to N do 78 | begin 79 | { STEP 4 } 80 | { approximation from Trapezoidal method } 81 | SUM := 0.0; 82 | M := round( exp( ( I - 2 ) * ln( 2.0 ) ) ); 83 | for K := 1 to M do SUM := SUM + F( A + ( K - 0.5 ) * H ); 84 | R[2,1] := ( R[1,1] + H * SUM ) / 2.0; 85 | { STEP 5 } 86 | { extrapolation } 87 | for J := 2 to I do 88 | begin 89 | L := round( exp( 2 * ( J - 1 ) * ln( 2.0 ) ) ); 90 | R[2,J] := R[2,J-1]+(R[2,J-1]-R[1,J-1])/(L-1.0) 91 | end; 92 | { STEP 6 } 93 | for K := 1 to I do write ( R[2,K]:12:8 ); 94 | writeln; writeln; 95 | { STEP 7 } 96 | H := H / 2.0; 97 | { STEP 8 } 98 | { since only two rows are kept in storage, this step } 99 | { is to prepare for the next row. } 100 | { update row 1 of R } 101 | for J := 1 to I do R[1,J] := R[2,J] 102 | end 103 | end 104 | { STEP 9 } 105 | end. -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG043.PAS: -------------------------------------------------------------------------------- 1 | program ALG043; 2 | { ADAPTIVE QUADRATURE ALGORITHM 4.3 3 | 4 | To approximate I = integral( ( f(x) dx ) ) from a to b to within 5 | a given tolerance TOL: 6 | 7 | INPUT: endpoints a, b; tolerance TOL; limit N to number of levels 8 | 9 | OUTPUT: approximation APP or message that N is exceeded. 10 | } 11 | var 12 | TOL,A,H,FA,FC,FB,S : array [1..20] of real; 13 | V : array [1..7] of real; 14 | L : array [1..20] of integer; 15 | AA,BB,EPS,APP,FD,FE,S1,S2 : real; 16 | CNT,N,I,LEV : integer; 17 | OK : boolean; 18 | AB : char; 19 | { Change function F for a new problem } 20 | function F ( X : real ) : real; 21 | begin 22 | CNT := CNT+1; 23 | F := 100.0 / ( X * X ) * sin( 10.0 / X ) 24 | end; 25 | procedure INPUT; 26 | begin 27 | writeln('This is Adaptive Quadrature with Simpsons Method.'); 28 | writeln(' '); 29 | write ('Has the function F been created in the program '); 30 | writeln ('immediately preceding '); 31 | writeln ('the INPUT procedure? '); 32 | writeln ('Enter Y or N '); 33 | readln ( AB ); 34 | if ( AB = 'Y' ) or ( AB = 'y' ) then 35 | begin 36 | OK := false; 37 | while ( not OK ) do 38 | begin 39 | write ('Input lower limit of integration and upper limit of '); 40 | writeln ('integration '); 41 | writeln ('separated by a blank '); 42 | readln ( AA, BB ); 43 | if ( AA >= BB ) then 44 | writeln ('Lower limit must be less than upper limit. ') 45 | else OK := true 46 | end; 47 | OK := false; 48 | while ( not OK ) do 49 | begin 50 | writeln ('Input tolerance '); 51 | readln ( EPS ); 52 | if ( EPS > 0.0 ) then OK := true 53 | else writeln ('Tolerance must be positive. ') 54 | end; 55 | OK := false; 56 | while ( not OK ) do 57 | begin 58 | writeln ('Input the maximum number of levels '); 59 | readln(N); 60 | if ( N > 0 ) then OK := true 61 | else writeln ('Number must be positive. ') 62 | end 63 | end 64 | else 65 | begin 66 | write ('The program will end so that the function F '); 67 | writeln ('can be created '); 68 | OK := false 69 | end 70 | end; 71 | procedure OUTPUT; 72 | begin 73 | writeln; 74 | writeln ('The integral of F from ',AA:12:8,' to ',BB:12:8,' is '); 75 | writeln ( APP:12:8,' to within ',EPS:14 ); 76 | writeln('The number of function evaluations is: ',CNT) 77 | end; 78 | begin 79 | INPUT; 80 | if (OK) then 81 | begin 82 | CNT := 0; 83 | OK := true; 84 | { STEP 1 } 85 | APP := 0.0; 86 | I := 1; 87 | TOL[I] := 10.0 * EPS; 88 | A[I] := AA; 89 | H[I] := 0.5 * ( BB - AA ); 90 | FA[I] := F( AA ); 91 | FC[I] := F( AA + H[I] ); 92 | FB[I] := F( BB ); 93 | { Approximation from Simpson's method for entire interval } 94 | S[I] := H[I] * ( FA[I] + 4.0 * FC[I] + FB[I] ) / 3.0; 95 | L[I] := 1; 96 | { STEP 2 } 97 | while ( ( I > 0 ) and OK ) do 98 | begin 99 | { STEP 3 } 100 | FD := F( A[I] + 0.5 * H[I] ); 101 | FE := F( A[I] + 1.5 * H[I] ); 102 | { Approximations from Simpson's method for halves of 103 | subintervals } 104 | S1 := H[I] * ( FA[I] + 4.0 * FD + FC[I] ) / 6.0; 105 | S2 := H[I] * ( FC[I] + 4.0 * FE + FB[I] ) / 6.0; 106 | { Save data at this level } 107 | V[1] := A[I]; 108 | V[2] := FA[I]; 109 | V[3] := FC[I]; 110 | V[4] := FB[I]; 111 | V[5] := H[I]; 112 | V[6] := TOL[I]; 113 | V[7] := S[I]; 114 | LEV := L[I]; 115 | { STEP 4 } 116 | { Delete the level. } 117 | I := I - 1; 118 | { STEP 5 } 119 | if ( abs( S1 + S2 - V[7] ) < V[6] ) then 120 | APP := APP + ( S1 + S2 ) 121 | else 122 | begin 123 | if ( LEV >= N ) then OK := false { Procedure fails } 124 | else 125 | begin 126 | { Add one level } 127 | { Data for right half subinterval } 128 | I := I + 1; 129 | A[I] := V[1] + V[5]; 130 | FA[I] := V[3]; 131 | FC[I] := FE; 132 | FB[I] := V[4]; 133 | H[I] := 0.5 * V[5]; 134 | TOL[I] := 0.5 * V[6]; 135 | S[I] := S2; 136 | L[I] := LEV + 1; 137 | { Data for left half subinterval } 138 | I := I + 1; 139 | A[I] := V[1]; 140 | FA[I] := V[2]; 141 | FC[I] := FD; 142 | FB[I] := V[3]; 143 | H[I] := H[I-1]; 144 | TOL[I] := TOL[I-1]; 145 | S[I] := S1; 146 | L[I] := L[I-1] 147 | end 148 | end 149 | end; 150 | if ( not OK ) then 151 | begin 152 | writeln ('Level exceeded. Method failed to give accurate '); 153 | writeln ('approximation.'); 154 | end 155 | else 156 | { STEP 6 } 157 | OUTPUT 158 | end 159 | end. 160 | 161 | 162 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG044.PAS: -------------------------------------------------------------------------------- 1 | program ALG044; 2 | { DOUBLE INTEGRAL ALGORITHM 4.4 3 | 4 | To approximate I = double integral ( ( f(x,y) dy dx ) ) with limits 5 | of integration from a to b for x and from c(x) to d(x) for y: 6 | 7 | INPUT: endpoints a, b; positive integers m, n. 8 | 9 | OUTPUT: approximation J to I. 10 | } 11 | var 12 | A,B,H,AN,AE,AO,X,HX,BN,YA,YB,BE,BO,Y,Z,A1,AC : real; 13 | N,M,NN,MM,I,J : integer; 14 | OK : boolean; 15 | AA : char; 16 | { Change functions F,C,D for a new problem } 17 | function F ( X, Y : real ) : real; 18 | { F is the integrand } 19 | begin 20 | F := exp( Y / X ) 21 | end; 22 | function C ( X : real ) : real; 23 | { C(X) is the lower limit of Y } 24 | begin 25 | C := X * X * X 26 | end; 27 | function D ( X : real ) : real; 28 | { D(X) is the upper limit of Y } 29 | begin 30 | D := X * X 31 | end; 32 | procedure INPUT; 33 | begin 34 | writeln('This is Simpsons Method for double integrals.'); 35 | writeln(' '); 36 | write ('Have the functions F, C and D been created in the '); 37 | writeln ('program immediately '); 38 | writeln ('preceding the INPUT procedure? '); 39 | writeln ('Enter Y or N '); 40 | readln ( AA ); 41 | if ( AA = 'Y' ) or ( AA = 'y' ) then 42 | begin 43 | OK := false; 44 | while ( not OK ) do 45 | begin 46 | write ('Input lower and upper limits of integration '); 47 | writeln ('of the outer integral separated '); 48 | writeln ('by a blank '); 49 | readln ( A, B ); 50 | if ( A >= B ) then 51 | begin 52 | write ('Lower limit must be less '); 53 | writeln ('than upper limit ') 54 | end 55 | else OK := true 56 | end; 57 | OK := false; 58 | while ( not OK ) do 59 | begin 60 | write ('Input two positive integers N, M; there will '); 61 | writeln ('be 2N subintervals for outer '); 62 | write ('integral and 2M subintervals for inner '); 63 | writeln ('integral - separate with blank '); 64 | readln ( N, M ); 65 | if ( ( M <= 0 ) or ( N <= 0 ) ) then 66 | writeln ('Integers must be positive ') 67 | else OK := true 68 | end 69 | end 70 | else 71 | begin 72 | write ('The program will end so that the functions F,C,D'); 73 | writeln (' can be created '); 74 | OK := false 75 | end 76 | end; 77 | procedure OUTPUT; 78 | begin 79 | writeln ('The integral of F from ',A:12:8,' to ',B:12:8,' is '); 80 | write ( AC:12:8 ); 81 | writeln (' obtained with N = ',N:3,' and M = ',M:3 ) 82 | end; 83 | begin 84 | INPUT; 85 | if (OK) then 86 | begin 87 | NN := 2 * N; 88 | MM := 2 * M - 1; 89 | { STEP 1 } 90 | H := ( B - A ) / NN; 91 | { use AN, AE, AO for J(1), J(2), J(3) resp. } 92 | { end terms } 93 | AN := 0.0; 94 | { even terms } 95 | AE := 0.0; 96 | { odd terms } 97 | AO := 0.0; 98 | { STEP 2 } 99 | for I := 0 to NN do 100 | begin 101 | { STEP 3 } 102 | { Composite Simpson's Method for X } 103 | X := A + I * H; 104 | YA := C( X ); 105 | YB := D( X ); 106 | HX := ( YB - YA ) / ( 2.0 * M ); 107 | { use BN, BE, BO for K(1), K(2), K(3) resp. } 108 | { end terms } 109 | BN := F( X, YA ) + F( X, YB ); 110 | { even terms } 111 | BE := 0.0; 112 | { odd terms } 113 | BO := 0.0; 114 | { STEP 4 } 115 | for J := 1 to MM do 116 | begin 117 | { STEP 5 } 118 | Y := YA + J * HX; 119 | Z := F( X, Y ); 120 | { STEP 6 } 121 | if ( J = J div 2 * 2 ) then BE := BE + Z 122 | else BO := BO + Z 123 | end; 124 | { STEP 7 } 125 | { use A1 for L, which is the integral of F(X(I),Y) from C(X(I)) 126 | to D(X(I)) by Composite Simpson's method } 127 | A1 := ( BN + 2.0 * BE + 4.0 * BO ) * HX / 3.0; 128 | { STEP 8 } 129 | if ( ( I = 0 ) or ( I = NN ) ) then AN := AN + A1 130 | else 131 | if ( I = I div 2 * 2 ) then AE := AE + A1 132 | else AO := AO + A1 133 | end; 134 | { STEP 9 } 135 | { Use AC for J } 136 | AC := ( AN + 2.0 * AE + 4.0 * AO ) * H / 3.0; 137 | { STEP 10 } 138 | OUTPUT 139 | end 140 | end. 141 | 142 | 143 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG045.PAS: -------------------------------------------------------------------------------- 1 | program ALG045; 2 | { GAUSSIAN DOUBLE INTEGRAL ALGORITHM 4.5 3 | 4 | To approximate I = double integral ( ( f(x,y) dy dx ) ) with limits 5 | of integration from a to b for x and from c(x) to d(x) for y: 6 | 7 | INPUT: endpoints a, b; positive integers m, n. (Assume that the 8 | roots r(i,j) and coefficients c(i,j) are available for 9 | i equals m and n for 1<= j <= i.) 10 | 11 | OUTPUT: approximation J to I. 12 | } 13 | var 14 | r,co : array [1..5,1..5] of real; 15 | A,B,H1,H2,AJ,JX,D1,C1,K1,K2,X,Y,Q : real; 16 | N,M,I,J : integer; 17 | OK : boolean; 18 | AA : char; 19 | { Change functions F,C,D for a new problem } 20 | function F ( X, Y : real ) : real; 21 | { F is the integrand } 22 | begin 23 | F := exp( Y / X ) 24 | end; 25 | function C ( X : real ) : real; 26 | { C(X) is the lower limit of Y } 27 | begin 28 | C := X * X * X 29 | end; 30 | function D ( X : real ) : real; 31 | { D(X) is the upper limit of Y } 32 | begin 33 | D := X * X 34 | end; 35 | procedure INPUT; 36 | begin 37 | writeln('This is Gaussian Quadrature for double integrals.'); 38 | write ('Have the functions F, C and D been created in the '); 39 | writeln ('program immediately '); 40 | writeln ('preceding the INPUT procedure? '); 41 | writeln ('Enter Y or N. '); 42 | readln ( AA ); 43 | if ( AA = 'Y' ) or ( AA = 'y' ) then 44 | begin 45 | OK := false; 46 | while ( not OK ) do 47 | begin 48 | write ('Input lower and upper limits of integration '); 49 | writeln ('of the outer integral separated '); 50 | writeln ('by a blank. '); 51 | readln ( A, B ); 52 | if ( A >= B ) then 53 | begin 54 | write ('Lower limit must be less '); 55 | writeln ('than upper limit. ') 56 | end 57 | else OK := true 58 | end; 59 | OK := false; 60 | while ( not OK ) do 61 | begin 62 | writeln; 63 | writeln ('Input two integers M,N. '); 64 | write('Both must be less than or equal to 5'); 65 | writeln(' and greater than 1'); 66 | writeln(' for this implementation.'); 67 | writeln ('Gaussian quadrature uses M for outer '); 68 | write ('integral and N for inner '); 69 | writeln ('integral - separate with blank. '); 70 | readln ( M, N ); 71 | if ( ( M <= 1 ) or ( N <= 1 ) ) then 72 | writeln ('Integers must be greater than 1. ') 73 | else 74 | if ( (M > 5) or (N > 5) ) then 75 | writeln('Integers must be less than or equal to 5') 76 | else OK := true; 77 | end 78 | end 79 | else 80 | begin 81 | write ('The program will end so that the functions F,C,D'); 82 | writeln (' can be created. '); 83 | OK := false 84 | end 85 | end; 86 | procedure OUTPUT; 87 | begin 88 | writeln; 89 | writeln ('The integral of F from ',A:12:8,' to ',B:12:8,' is '); 90 | write ( AJ:14:10 ); 91 | writeln (' obtained with M = ',M:3,' and N = ',N:3 ); 92 | end; 93 | begin 94 | INPUT; 95 | if (OK) then 96 | begin 97 | { Initialize coefficients c[i,j] and roots r[i,j] } 98 | r[2,1] := 0.5773502692; r[2,2] := -r[2,1]; co[2,1] := 1.0; 99 | co[2,2] := 1.0; r[3,1] := 0.7745966692; r[3,2] := 0.0; 100 | r[3,3] := -r[3,1]; co[3,1] := 0.5555555556; co[3,2] := 0.8888888889; 101 | co[3,3] := co[3,1]; r[4,1] := 0.8611363116; r[4,2] := 0.3399810436; 102 | r[4,3] := -r[4,2]; r[4,4] := -r[4,1]; co[4,1] := 0.3478548451; 103 | co[4,2] := 0.6521451549; co[4,3] := co[4,2]; co[4,4] := co[4,1]; 104 | r[5,1] := 0.9061798459; r[5,2] := 0.5384693101; r[5,3] := 0.0; 105 | r[5,4] := -r[5,2]; r[5,5] := -r[5,1]; co[5,1] := 0.2369268850; 106 | co[5,2] := 0.4786286705; co[5,3] := 0.5688888889; co[5,4] := co[5,2]; 107 | co[5,5] := co[5,1]; 108 | { STEP 1 } 109 | H1 := ( B - A ) / 2.0; 110 | H2 := ( B + A ) / 2.0; 111 | AJ := 0.0; { Use AJ instead of J. } 112 | { STEP 2 } 113 | for I := 1 to M do 114 | begin 115 | { STEP 3 } 116 | X := H1 * r[M,I] + H2; 117 | JX := 0.0; 118 | C1 := C( X ); 119 | D1 := D( X ); 120 | K1 := ( D1 - C1 ) / 2.0 ; 121 | K2 := ( D1 + C1 ) / 2.0; 122 | { STEP 4 } 123 | for J := 1 to N do 124 | begin 125 | Y := K1 * r[N,J] + K2; 126 | Q := F( X, Y ); 127 | JX := JX + co[N,J] * Q 128 | end; 129 | { STEP 5 } 130 | AJ := AJ + co[M,I] * K1 * JX 131 | end; 132 | { STEP 6 } 133 | AJ := AJ * H1; 134 | { STEP 7 } 135 | OUTPUT 136 | end 137 | end. 138 | 139 | 140 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG051.PAS: -------------------------------------------------------------------------------- 1 | program ALG051; 2 | { EULER'S ALGORITHM 5.1 3 | 4 | TO APPROXIMATE THE SOLUTION OF THE INITIAL VALUE PROBLEM: 5 | Y' = F(T,Y), A<=T<=B, Y(A) = ALPHA, 6 | AT N+1 EQUALLY SPACED POINTS IN THE INTERVAL [A,B]. 7 | 8 | INPUT: ENDPOINTS A,B; INITIAL CONDITION ALPHA; INTEGER N. 9 | 10 | OUTPUT: APPROXIMATION W TO Y AT THE (N+1) VALUES OF T. 11 | } 12 | var 13 | OUP : text; 14 | A,B,ALPHA,H,T,W : real; 15 | FLAG,I,N : integer; 16 | OK : boolean; 17 | AA : char; 18 | NAME : string [ 30 ]; 19 | { Change function F for a new problem. } 20 | function F ( T, Y : real ) : real; 21 | begin 22 | F := Y - T*T + 1.0 23 | end; 24 | procedure INPUT; 25 | begin 26 | writeln('This is Eulers Method.'); 27 | write ('Has the function F been defined? '); 28 | writeln ('Answer Y or N. '); 29 | readln ( AA ); 30 | OK := false; 31 | if ( AA = 'Y' ) or ( AA = 'y' ) then 32 | begin 33 | OK := false; 34 | while ( not OK ) do 35 | begin 36 | writeln('Input left and right endpoints separated by blank '); 37 | readln ( A, B ); 38 | if ( A >= B ) then 39 | writeln ('Left endpoint must be less than right endpoint ') 40 | else OK := true 41 | end; 42 | writeln ('Input the initial condition '); 43 | readln ( ALPHA ); 44 | OK := false; 45 | while ( not OK ) do 46 | begin 47 | write ('Input a positive integer for the number of '); 48 | writeln ('subintervals '); 49 | readln ( N ); 50 | if ( N <= 0 ) then 51 | writeln ('Number must be a positive integer ') 52 | else OK := true 53 | end; 54 | end 55 | else 56 | writeln ('The program will end so that the function can be created.') 57 | end; 58 | procedure OUTPUT; 59 | begin 60 | writeln ('Choice of output method: '); 61 | writeln ('1. Output to screen '); 62 | writeln ('2. Output to text file '); 63 | writeln ('Please enter 1 or 2 '); 64 | readln ( FLAG ); 65 | if ( FLAG = 2 ) then 66 | begin 67 | writeln ('Input the file name in the form - drive:name.ext '); 68 | readln ( NAME ); 69 | assign ( OUP, NAME ) 70 | end 71 | else assign ( OUP, 'CON' ); 72 | rewrite ( OUP ); 73 | writeln ( OUP,'EULERS METHOD' ); 74 | writeln ( OUP ); 75 | writeln ( OUP,'t':5,'w':12); 76 | writeln (OUP) 77 | end; 78 | begin 79 | INPUT; 80 | if OK then 81 | begin 82 | OUTPUT; 83 | { STEP 1 } 84 | H := ( B - A ) / N; 85 | T := A; 86 | W := ALPHA; 87 | writeln ( OUP,T:5:3,W:12:7); 88 | { STEP 2 } 89 | for I := 1 to N do 90 | begin 91 | { STEP 3 } 92 | { COMPUTE W(I) } 93 | W := W + H * F( T, W ); 94 | { COMPUTE T(I) } 95 | T := A + I * H; 96 | { STEP 4 } 97 | writeln ( OUP,T:5:3,W:12:7); 98 | end; 99 | { STEP 5 } 100 | close ( OUP ) 101 | end 102 | end. -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG052.PAS: -------------------------------------------------------------------------------- 1 | program ALG052; 2 | { RUNGE-KUTTA (ORDER 4) ALGORITHM 5.2 3 | 4 | TO APPROXIMATE THE SOLUTION TO THE INITIAL VALUE PROBLEM: 5 | Y' = F(T,Y), A<=T<=B, Y(A) = ALPHA, 6 | AT (N+1) EQUALLY SPACED NUMBERS IN THE INTERVAL [A,B]. 7 | 8 | INPUT: ENDPOINTS A,B; INITIAL CONDITION ALPHA; INTEGER N. 9 | 10 | OUTPUT: APPROXIMATION W TO Y AT THE (N+1) VALUES OF T. 11 | } 12 | var 13 | OUP : text; 14 | A,B,ALPHA,H,T,W,K1,K2,K3,K4 : real; 15 | FLAG,I,N : integer; 16 | OK : boolean; 17 | AA : char; 18 | NAME : string [ 30 ]; 19 | { Change function F for a new problem. } 20 | function F ( T, Y : real ) : real; 21 | begin 22 | F := Y - T*T + 1.0 23 | end; 24 | procedure INPUT; 25 | begin 26 | writeln('This is the Runge-Kutta Order Four Method.'); 27 | OK := false; 28 | write ('Has the function F been created in the program? '); 29 | writeln ('Answer Y or N. '); 30 | readln ( AA ); 31 | if ( AA = 'Y' ) or ( AA = 'y' ) then 32 | begin 33 | OK := false; 34 | while ( not OK ) do 35 | begin 36 | writeln('Input left and right endpoints separated by blank '); 37 | readln ( A, B ); 38 | if ( A >= B ) then 39 | writeln ('Left endpoint must be less than right endpoint ') 40 | else OK := true 41 | end; 42 | writeln ('Input the initial condition'); 43 | readln ( ALPHA ); 44 | OK := false; 45 | while ( not OK ) do 46 | begin 47 | write ('Input a positive integer for the number of '); 48 | writeln ('subintervals '); 49 | readln ( N ); 50 | if ( N <= 0 ) then 51 | writeln ('Number must be a positive integer ') 52 | else OK := true 53 | end; 54 | end 55 | else 56 | writeln ('The program will end so that the function can be created.') 57 | end; 58 | procedure OUTPUT; 59 | begin 60 | writeln ('Choice of output method: '); 61 | writeln ('1. Output to screen '); 62 | writeln ('2. Output to text file '); 63 | writeln ('Please enter 1 or 2 '); 64 | readln ( FLAG ); 65 | if ( FLAG = 2 ) then 66 | begin 67 | writeln ('Input the file name in the form - drive:name.ext '); 68 | readln ( NAME ); 69 | assign ( OUP, NAME ) 70 | end 71 | else assign ( OUP, 'CON' ); 72 | rewrite ( OUP ); 73 | writeln(OUP,'RUNGE-KUTTA FOURTH ORDER METHOD'); 74 | writeln(OUP); 75 | writeln ( OUP,'t':5,'w':12); 76 | writeln ( OUP ) 77 | end; 78 | begin 79 | INPUT; 80 | if OK then 81 | begin 82 | OUTPUT; 83 | { STEP 1 } 84 | H := ( B - A ) / N; 85 | T := A; 86 | W := ALPHA; 87 | writeln ( OUP,T:5:3,W:12:7); 88 | { STEP 2 } 89 | for I := 1 to N do 90 | begin 91 | { STEP 3 } 92 | { USE K1, K2, K3, K4 FOR K(1), K(2), K(3), K(4) RESP. } 93 | K1 := H * F( T, W ); 94 | K2 := H * F( T + H / 2.0, W + K1 / 2.0 ); 95 | K3 := H * F( T + H / 2.0, W + K2 / 2.0 ); 96 | K4 := H * F( T + H, W + K3 ); 97 | { STEP 4 } 98 | { COMPUTE W(I) } 99 | W := W + ( K1 + 2.0 * ( K2 + K3 ) + K4 ) / 6.0; 100 | { COMPUTE T(I) } 101 | T := A + I * H; 102 | { STEP 5 } 103 | writeln ( OUP,T:5:3,W:12:7); 104 | end; 105 | { STEP 6 } 106 | close ( OUP ) 107 | end 108 | end. -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG053.PAS: -------------------------------------------------------------------------------- 1 | program ALG053; 2 | { RUNGE-KUTTA-FEHLBERG ALGORITHM 5.3 3 | 4 | TO APPROXIMATE THE SOLUTION OF THE INITIAL VALUE PROBLEM: 5 | Y' = F(T,Y), A<=T<=B, Y(A) = ALPHA, 6 | WITH LOCAL TRUNCATION ERROR WITHIN A GIVEN TOLERANCE. 7 | 8 | INPUT: ENDPOINTS A,B; INITIAL CONDITION ALPHA; TOLERANCE TOL; 9 | MAXIMUM STEPSIZE HMAX; MINIMUM STEPSIZE HMIN. 10 | 11 | OUTPUT: T, W, H WHERE W APPROXIMATES Y(T) AND STEPSIZE H WAS 12 | USED OR A MESSAGE THAT MINIMUM STEPSIZE WAS EXCEEDED. 13 | } 14 | var 15 | OUP : text; 16 | A,B,TOL,ALPHA,HMAX,HMIN,H,T,W,K1,K2,K3,K4,K5,K6,R,DELTA : real; 17 | FLAG,I,N : integer; 18 | OK : boolean; 19 | AA : char; 20 | NAME : string [ 30 ]; 21 | { Change function F for a new problem. } 22 | function F ( T, Y : real ) : real; 23 | begin 24 | F := Y - T*T + 1.0 25 | end; 26 | procedure INPUT; 27 | begin 28 | writeln('This is the Runge-Kutta-Fehlberg Method.'); 29 | OK := false; 30 | write ('Has the function F been defined? '); 31 | writeln ('Answer Y or N. '); 32 | readln ( AA ); 33 | if ( AA = 'Y' ) or ( AA = 'y' ) then 34 | begin 35 | OK := false; 36 | while ( not OK ) do 37 | begin 38 | writeln('Input left and right endpoints separated by blank '); 39 | readln ( A, B ); 40 | if ( A >= B ) then 41 | writeln ('Left endpoint must be less than right endpoint ') 42 | else OK := true 43 | end; 44 | writeln ('Input the initial condition '); 45 | readln ( ALPHA ); 46 | OK := false; 47 | while ( not OK ) do 48 | begin 49 | writeln ('Input tolerance '); 50 | readln ( TOL ); 51 | if ( TOL <= 0.0 ) then 52 | writeln ('Tolerance must be positive. ') 53 | else OK := true 54 | end; 55 | OK := false; 56 | while ( not OK ) do 57 | begin 58 | write ('Input minimum and maximum mesh spacing separated by '); 59 | writeln ('blank '); 60 | readln ( HMIN, HMAX ); 61 | if ( HMIN < HMAX ) and ( HMIN > 0.0 ) then OK := true 62 | else 63 | begin 64 | write ('Minimum mesh spacing must be a positive real '); 65 | writeln ('number and less than '); 66 | writeln ('the maximum mesh spacing ') 67 | end 68 | end 69 | end 70 | else 71 | writeln ('The program will end so that the function can be created.') 72 | end; 73 | procedure OUTPUT; 74 | begin 75 | writeln ('Choice of output method: '); 76 | writeln ('1. Output to screen '); 77 | writeln ('2. Output to text file '); 78 | writeln ('Please enter 1 or 2 '); 79 | readln ( FLAG ); 80 | if ( FLAG = 2 ) then 81 | begin 82 | writeln ('Input the file name in the form - drive:name.ext '); 83 | readln ( NAME ); 84 | assign ( OUP, NAME ) 85 | end 86 | else assign ( OUP, 'CON' ); 87 | rewrite ( OUP ); 88 | writeln(OUP,'RUNGE-KUTTA-FEHLBERG METHOD'); 89 | writeln(OUP); 90 | writeln ( OUP,'T(I)':12,'W(I)':12,'H':12,'R':12); 91 | writeln ( OUP ) 92 | end; 93 | begin 94 | INPUT; 95 | if OK then 96 | begin 97 | OUTPUT; 98 | { STEP 1 } 99 | H := HMAX; 100 | T := A; 101 | W := ALPHA; 102 | writeln ( OUP,T:12:7,W:12:7,'0':12,'0':12); 103 | OK := true; 104 | { STEP 2 } 105 | while ( ( T < B ) and OK ) do 106 | begin 107 | { STEP 3 } 108 | K1 := H*F(T,W); 109 | K2 := H*F(T+H/4,W+K1/4); 110 | K3 := H*F(T+3*H/8,W+(3*K1+9*K2)/32); 111 | K4 := H*F(T+12*H/13,W+(1932*K1-7200*K2+7296*K3)/2197); 112 | K5 := H*F(T+H,W+439*K1/216-8*K2+3680*K3/513-845*K4/4104); 113 | K6 := H*F(T+H/2,W-8*K1/27+2*K2-3544*K3/2565 114 | +1859*K4/4104-11*K5/40); 115 | { STEP 4 } 116 | R := abs(K1/360-128*K3/4275-2197*K4/75240.0 117 | +K5/50+2*K6/55)/H; 118 | { STEP 5 } 119 | if ( R <= TOL ) then 120 | begin 121 | { STEP 6 } 122 | { APPROXIMATION ACCEPTED } 123 | T := T + H; 124 | W := W+25*K1/216+1408*K3/2565+2197*K4/4104-K5/5; 125 | { STEP 7 } 126 | writeln(OUP,T:12:7,W:12:7,H:12:7,R:12:7) 127 | end; 128 | { STEP 8 } 129 | { TO AVOID UNDERFLOW } 130 | if ( R > 1.0E-20 ) then 131 | DELTA := 0.84 * exp( 0.25 * ln( TOL / R ) ) 132 | else DELTA := 10.0; 133 | { STEP 9 } 134 | { CALCULATE NEW H } 135 | if ( DELTA <= 0.1 ) then H := 0.1 * H 136 | else 137 | if ( DELTA >= 4.0 ) then H := 4.0 * H 138 | else H := DELTA * H; 139 | { STEP 10 } 140 | if ( H > HMAX ) then H := HMAX; 141 | { STEP 11 } 142 | if ( H < HMIN ) then OK := false 143 | else 144 | if ( T + H > B ) then 145 | if (abs(B-T) < TOL) then T := B 146 | else H := B - T 147 | end; 148 | if ( not OK ) then writeln ( OUP, 'Minimal H exceeded '); 149 | { STEP 12 } 150 | { PROCESS IS COMPLETE } 151 | close ( OUP ) 152 | end 153 | end. 154 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG054.PAS: -------------------------------------------------------------------------------- 1 | program ALG054; 2 | { ADAMS-FORTH ORDER PREDICTOR-CORRECTOR ALGORITHM 5.4 3 | 4 | To approximate the solution of the initial value problem 5 | y' = f(t,y), a <= t <= b, y(a) = alpha, 6 | at N+1 equally spaced points in the interval [a,b]. 7 | 8 | INPUT: endpoints a,b; initial condition alpha; integer N. 9 | 10 | OUTPUT: approximation w to y at the (N+1) values of t. 11 | } 12 | var 13 | T,W : array [ 1..4 ] of real; 14 | A,B,ALPHA,H,T0,W0 : real; 15 | FLAG,I,N,J : integer; 16 | OK : boolean; 17 | NAME : string [ 30 ]; 18 | OUP : text; 19 | AA : char; 20 | { Change function F for a new problem. } 21 | function F ( T, Y : real ) : real; 22 | begin 23 | F := Y - T*T + 1.0 24 | end; 25 | procedure RK4 ( H, T0, W0 : real; var T1, W1 : real ); 26 | var 27 | K1, K2, K3, K4 : real; 28 | begin 29 | T1 := T0 + H; 30 | K1 := H * F( T0, W0 ); 31 | K2 := H * F( T0 + 0.5 * H, W0 + 0.5 * K1 ); 32 | K3 := H * F(T0 + 0.5 * H, W0 + 0.5 * K2 ); 33 | K4 := H * F( T1, W0 + K3 ); 34 | W1 := W0 + ( K1 + 2.0 * ( K2 + K3 ) + K4 ) / 6.0 35 | end; 36 | procedure INPUT; 37 | begin 38 | writeln('This is Adams-Bashforth Predictor Corrector Method'); 39 | writeln('Has the function F been created in the program immediately'); 40 | writeln('preceding the INPUT procedure? Enter Y or N.'); 41 | readln(AA); 42 | if ((AA = 'Y') or (AA = 'y')) then 43 | begin 44 | OK := false; 45 | while ( not OK ) do 46 | begin 47 | writeln('Input left and right endpoints separated by blank.'); 48 | readln ( A, B ); 49 | if ( A >= B ) then 50 | writeln('Left endpoint must be less than right endpoint.') 51 | else OK := true 52 | end; 53 | writeln ('Input the initial condition. '); 54 | readln ( ALPHA ); 55 | OK := false; 56 | while ( not OK ) do 57 | begin 58 | writeln ('Input an integer greater than or equal to 4 '); 59 | writeln ('for the number of subintervals. '); 60 | readln ( N ); 61 | if ( N < 4 ) then 62 | writeln ('Number must be greater than or equal to 4. ') 63 | else OK := true 64 | end; 65 | end 66 | else 67 | begin 68 | writeln('The program will end so that F can be created.'); 69 | OK := false 70 | end 71 | end; 72 | procedure OUTPUT; 73 | begin 74 | writeln ('Choice of output method: '); 75 | writeln ('1. Output to screen '); 76 | writeln ('2. Output to text file '); 77 | writeln ('Please enter 1 or 2. '); 78 | readln ( FLAG ); 79 | if ( FLAG = 2 ) then 80 | begin 81 | writeln ('Input the file name in the form - drive:name.ext, '); 82 | writeln('for example: A:OUTPUT.DTA'); 83 | readln ( NAME ); 84 | assign ( OUP, NAME ) 85 | end 86 | else assign ( OUP, 'CON' ); 87 | rewrite ( OUP ); 88 | writeln(OUP,'ADAMS-BASHFORTH FOURTH ORDER PREDICTOR CORRECTOR METHOD'); 89 | writeln ( OUP ); 90 | writeln(OUP,'t':5,'w':12); 91 | end; 92 | begin 93 | INPUT; 94 | if (OK) then 95 | begin 96 | OUTPUT; 97 | { STEP 1 } 98 | { The subscripts are shifted to avoid zero subscripts } 99 | H := ( B - A ) / N; 100 | T[1] := A; 101 | W[1] := ALPHA; 102 | writeln(OUP,T[1]:5:3,W[1]:12:7); 103 | { STEP 2 } 104 | for I := 1 to 3 do 105 | begin 106 | { STEP 3 AND 4 } 107 | { compute starting values using Runge-Kutta method 108 | given in a subroutine } 109 | RK4( H, T[I], W[I], T[I+1], W[I+1] ); 110 | writeln(OUP,T[I+1]:5:3,W[I+1]:12:7); 111 | { STEP 5 } 112 | end; 113 | { STEP 6 } 114 | for I := 4 to N do 115 | begin 116 | { STEP 7 } 117 | { T0, W0 will be used in place of t, w resp. } 118 | T0 := A + I * H; 119 | { predict W(I) } 120 | W0 := W[4]+H*(55.0*F(T[4],W[4])-59.0*F(T[3],W[3]) 121 | +37.0*F(T[2],W[2])-9.0*F(T[1],W[1]))/24.0; 122 | { correct W(I) } 123 | W0 := W[4]+H*(9.0*F(T0,W0)+19.0*F(T[4],W[4]) 124 | -5.0*F(T[3],W[3])+F(T[2],W[2]))/24.0; 125 | { STEP 8 } 126 | writeln(OUP,T0:5:3,W0:12:7); 127 | { STEP 9 } 128 | { prepare for next iteration } 129 | for J := 1 to 3 do 130 | begin 131 | T[J] := T[J+1]; 132 | W[J] := W[J+1] 133 | end; 134 | { STEP 10 } 135 | T[4] := T0; 136 | W[4] := W0 137 | end; 138 | { STEP 11 } 139 | close ( OUP ) 140 | end 141 | end. -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG057.PAS: -------------------------------------------------------------------------------- 1 | program ALG057; 2 | { RUNGE-KUTTA FOR SYSTEMS OF DIFFERENTIAL EQUATIONS ALGORITHM 5.7 3 | 4 | TO APPROXIMATE THE SOLUTION OF THE MTH-ORDER SYSTEM OF FIRST- 5 | ORDER INITIAL-VALUE PROBLEMS 6 | UJ' = FJ( T, U1, U2, ..., UM ), J = 1, 2, ..., M 7 | A <= T <= B, UJ(A) = ALPHAJ, J = 1, 2, ..., M 8 | AT (N+1) EQUALLY SPACED NUMBERS IN THE INTERVAL [A,B]. 9 | 10 | INPUT: ENDPOINTS A,B; NUMBER OF EQUATIONS M; INITIAL 11 | CONDITIONS ALPHA1, ..., ALPHAM; INTEGER N. 12 | 13 | OUTPUT: APPROXIMATION WJ TO UJ(T) AT THE (N+1) VALUES OF T. 14 | } 15 | var 16 | A,B,ALPHA1,ALPHA2,H,T,W1,W2,X11,X12,X21,X22,X31,X32,X41,X42 : real; 17 | FLAG,N,I : integer; 18 | AA : char; 19 | OK : boolean; 20 | NAME : string [ 30 ]; 21 | OUP : text; 22 | { Change functions F1 and F2 for a new problem. } 23 | function F1 ( T, X1, X2 : real ) : real; 24 | begin 25 | F1 := -4*X1+3*X2+6 26 | end; 27 | function F2 ( T, X1, X2 : real ) : real; 28 | begin 29 | F2 := -2.4*X1+1.6*X2+3.6 30 | end; 31 | procedure INPUT; 32 | begin 33 | writeln('This is the Runge-Kutta Method for Systems with m = 2.'); 34 | OK := false; 35 | write ('Have the functions F1 and F2 been defined? '); 36 | writeln ('Answer Y or N. '); 37 | readln ( AA ); 38 | if ( AA = 'Y' ) or ( AA = 'y' ) then 39 | begin 40 | OK := false; 41 | while ( not OK ) do 42 | begin 43 | writeln('Input left and right endpoints separated by blank '); 44 | readln ( A, B ); 45 | if ( A >= B ) then 46 | writeln ('Left endpoint must be less than right endpoint ') 47 | else OK := true 48 | end; 49 | writeln('Input the two initial conditions, separated by blank '); 50 | readln ( ALPHA1, ALPHA2 ); 51 | OK := false; 52 | while ( not OK ) do 53 | begin 54 | write ('Input a positive integer for the number of '); 55 | writeln ('subintervals '); 56 | readln ( N ); 57 | if ( N <= 0 ) then 58 | writeln ('Number must be a positive integer ') 59 | else OK := true 60 | end; 61 | end 62 | else 63 | writeln ('The program will end so that the functions can be created.') 64 | end; 65 | procedure OUTPUT; 66 | begin 67 | writeln ('Choice of output method: '); 68 | writeln ('1. Output to screen '); 69 | writeln ('2. Output to text file '); 70 | writeln ('Please enter 1 or 2 '); 71 | readln ( FLAG ); 72 | if ( FLAG = 2 ) then 73 | begin 74 | writeln ('Input the file name in the form - drive:name.ext '); 75 | readln ( NAME ); 76 | assign ( OUP, NAME ) 77 | end 78 | else assign ( OUP, 'CON' ); 79 | rewrite ( OUP ); 80 | writeln(OUP,'RUNGE-KUTTA METHOD FOR SYSTEMS WITH m = 2.'); 81 | writeln ( OUP, 'T':5,'W1':12,'W2':12); 82 | writeln ( OUP ); 83 | end; 84 | begin 85 | INPUT; 86 | if OK then 87 | begin 88 | OUTPUT; 89 | { STEP 1 } 90 | H := ( B - A ) / N; 91 | T := A; 92 | { STEP 2 } 93 | W1 := ALPHA1; 94 | W2 := ALPHA2; 95 | { STEP 3 } 96 | writeln ( OUP,T:5:3,W1:12:8,W2:12:8); 97 | { STEP 4 } 98 | for I := 1 to N do 99 | begin 100 | { STEP 5 } 101 | X11 := H * F1( T, W1, W2 ); 102 | X12 := H * F2( T, W1, W2 ); 103 | { STEP 6 } 104 | X21 := H * F1( T + H / 2.0, W1 + X11 / 2.0, W2 + X12 / 2.0 ); 105 | X22 := H * F2( T + H / 2.0, W1 + X11 / 2.0, W2 + X12 / 2.0 ); 106 | { STEP 7 } 107 | X31 := H * F1( T + H / 2.0, W1 + X21 / 2.0, W2 + X22 / 2.0 ); 108 | X32 := H * F2( T + H / 2.0, W1 + X21 / 2.0, W2 + X22 / 2.0 ); 109 | { SYEP 8 } 110 | X41 := H * F1( T + H, W1 + X31, W2 + X32 ); 111 | X42 := H * F2( T + H, W1 + X31, W2 + X32 ); 112 | { STEP 9 } 113 | W1 := W1 + ( X11 + 2.0 * X21 + 2.0 * X31 + X41 ) / 6.0; 114 | W2 := W2 + ( X12 + 2.0 * X22 + 2.0 * X32 + X42 ) / 6.0; 115 | { STEP 10 } 116 | T := A + I * H; 117 | { STEP 11 } 118 | writeln ( OUP,T:5:3,W1:12:8,W2:12:8); 119 | end; 120 | { STEP 12 } 121 | close ( OUP ) 122 | end 123 | end. 124 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG058.PAS: -------------------------------------------------------------------------------- 1 | program ALG058; 2 | { TRAPEZOIDAL WITH NEWTON ITERATION ALGORITHM 5.8 3 | 4 | TO APPROXIMATE THE SOLUTION OF THE INITIAL VALUE PROBLEM: 5 | Y' = F(T,Y), A <= T <= B, Y(A) = ALPHA, 6 | AT (N+1) EQUALLY SPACED NUMBERS IN THE INTERVAL [A,B]. 7 | 8 | INPUT: ENDPOINTS A,B; INITIAL CONDITION ALPHA; INTEGER N. 9 | TOLERANCE TOL; MAXIMUM NUMBER OF ITERATIONS M AT ANY ONE STEP. 10 | 11 | OUTPUT: APPROXIMATION W TO Y AT THE (N+1) VALUES OF T 12 | OR A MESSAGE OF FAILURE. 13 | } 14 | var 15 | A,B,ALPHA,TOL,W,T,H,XK1,W0,Y : real; 16 | FLAG,N,M,I,J,IFLAG : integer; 17 | OK : boolean; 18 | AA : char; 19 | NAME : string [ 30 ]; 20 | OUP : text; 21 | { Change functions F and FYP for a new problem. } 22 | function F ( T, Y : real ) : real; 23 | begin 24 | F := 5*exp(5*T)*sqr(Y-T)+1 25 | end; 26 | { Function FYP is the partial derivative of F with respect to Y. } 27 | function FYP ( T, Y : real ) : real; 28 | begin 29 | FYP := 10*exp(5*T)*(Y-T) 30 | end; 31 | procedure INPUT; 32 | begin 33 | writeln('This is the Implicit Trapezoidal Method.'); 34 | OK := false; 35 | write ('Have the functions F and FYP been defined? '); 36 | writeln ('Answer Y or N. '); 37 | readln ( AA ); 38 | if ( AA = 'Y' ) or ( AA = 'y' ) then 39 | begin 40 | OK := false; 41 | while ( not OK ) do 42 | begin 43 | writeln ('Input left and right endpoints separated by blank '); 44 | readln ( A, B ); 45 | if ( A >= B ) then 46 | writeln ('Left endpoint must be less than right endpoint ') 47 | else OK := true 48 | end; 49 | writeln ('Input the initial condition '); 50 | readln ( ALPHA ); 51 | OK := false; 52 | while ( not OK ) do 53 | begin 54 | write ('Input a positive integer for the number of '); 55 | writeln ('subintervals '); 56 | readln ( N ); 57 | if ( N <= 0 ) then 58 | writeln ('Number must be a positive integer ') 59 | else OK := true 60 | end; 61 | OK := false; 62 | while ( not OK ) do 63 | begin 64 | writeln ('Input tolerance '); 65 | readln ( TOL ); 66 | if ( TOL > 0.0 ) then OK := true 67 | else writeln ('Tolerance must be a positve real number ') 68 | end; 69 | OK := false; 70 | while ( not OK ) do 71 | begin 72 | writeln ('Input the maximum number of iterations '); 73 | readln ( M ); 74 | if ( M > 0 ) then OK := true 75 | else writeln ('Number of iterations must be positive ') 76 | end 77 | end 78 | else 79 | writeln ('The program will end so that the functions can be created.') 80 | end; 81 | procedure OUTPUT; 82 | begin 83 | writeln ('Choice of output method: '); 84 | writeln ('1. Output to screen '); 85 | writeln ('2. Output to text file '); 86 | writeln ('Please enter 1 or 2 '); 87 | readln ( FLAG ); 88 | if ( FLAG = 2 ) then 89 | begin 90 | writeln ('Input the file name in the form - drive:name.ext '); 91 | readln ( NAME ); 92 | assign ( OUP, NAME ) 93 | end 94 | else assign ( OUP, 'CON' ); 95 | rewrite ( OUP ); 96 | writeln(OUP,'IMPLICIT TRAPEZOIDAL METHOD USING NEWTONS METHOD'); 97 | writeln ( OUP ); 98 | writeln ( OUP,'t':5,'w':12,' #iter'); 99 | end; 100 | begin 101 | INPUT; 102 | if OK then 103 | begin 104 | OUTPUT; 105 | { STEP 1 } 106 | W := ALPHA; 107 | T := A; 108 | H := ( B - A ) / N; 109 | writeln ( OUP,T:5:3,W:12:8,'0':4); 110 | I := 1; 111 | OK:= true; 112 | { STEP 2 } 113 | while( ( I <= N ) and OK ) do 114 | begin 115 | { STEP 3 } 116 | XK1 := W + 0.5 * H * F( T, W ); 117 | W0 := XK1; 118 | J := 1; 119 | IFLAG := 0; 120 | { STEP 4 } 121 | while ( ( IFLAG = 0 ) and OK ) do 122 | begin 123 | { STEP 5 } 124 | W := W0 - ( W0 - XK1 - 0.5 * H * F( T + H, W0 ) ) / 125 | ( 1.0 - 0.5 * H * FYP( T + H, W0 ) ); 126 | { STEP 6 } 127 | if ( abs( W - W0 ) < TOL ) then 128 | begin 129 | IFLAG := 1; 130 | { STEP 7 } 131 | T := A + I * H; 132 | writeln(OUP,T:5:3,W:12:8,J:4); 133 | I := I + 1; 134 | end 135 | else 136 | begin 137 | J := J + 1; 138 | W0 := W; 139 | if ( J > M ) then OK := false 140 | end 141 | end 142 | end; 143 | if ( not OK ) then 144 | writeln ( OUP, 'Maximum number of iterations ',M,' exceeded.'); 145 | { STEP 8 } 146 | close ( OUP ) 147 | end 148 | end. -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG065.PAS: -------------------------------------------------------------------------------- 1 | program ALG065; 2 | { LDL-t ALGORITHM 6.5 3 | 4 | To factor the positive definite n by n matrix A into LDL**T, 5 | where L is a lower triangular matrix with ones along the diagonal 6 | and D is a diagonal matrix with positive entries on the 7 | diagonal. 8 | 9 | INPUT: the dimension n; entries A(I,J), 1<=I, J<=n of A. 10 | 11 | OUTPUT: the entries L(I,J), 1<=J 0 ) then 49 | begin 50 | for I := 1 to N do 51 | for J := 1 to N do read ( INP, A[I,J] ); 52 | OK := true 53 | end 54 | else writeln ('The number must be a positive integer. ') 55 | end; 56 | close ( INP ) 57 | end 58 | else 59 | begin 60 | write ('The program will end so'); 61 | writeln(' the input file can be created. '); 62 | OK := false 63 | end 64 | end; 65 | procedure OUTPUT; 66 | begin 67 | writeln ('Choice of output method: '); 68 | writeln ('1. Output to screen '); 69 | writeln ('2. Output to text file '); 70 | writeln ('Please enter 1 or 2. '); 71 | readln ( FLAG ); 72 | if ( FLAG = 2 ) then 73 | begin 74 | writeln ('Input the file name in the form - drive:name.ext, '); 75 | writeln('for example: A:OUTPUT.DTA'); 76 | readln ( NAME ); 77 | assign ( OUP, NAME ) 78 | end 79 | else assign ( OUP, 'CON' ); 80 | rewrite ( OUP ); 81 | writeln(OUP,'LDL^t FACTORIZATION'); 82 | writeln(OUP); 83 | writeln ( OUP, 'The matrix L output by rows: '); 84 | for I := 1 to N do 85 | begin 86 | for J := 1 to I-1 do write ( OUP, '':2, A[I,J]:12:8 ); 87 | writeln ( OUP ) 88 | end; 89 | writeln( OUP, 'The diagonal of D: '); 90 | for I := 1 to N do write ( OUP, '':2, D[I]:12:8 ); 91 | writeln ( OUP ) 92 | end; 93 | begin 94 | INPUT; 95 | if ( OK ) then 96 | begin 97 | { STEP 1 } 98 | for I := 1 to N do 99 | begin 100 | { STEP 2 } 101 | for J := 1 to I-1 do V[J] := A[I,J] * D[J]; 102 | { STEP 3 } 103 | D[I] := A[I,I]; 104 | for J := 1 to I-1 do D[I] := D[I] - A[I,J] * V[J]; 105 | { STEP 4 } 106 | for J := I+1 to N do 107 | begin 108 | for K := 1 to I-1 do 109 | A[J,I] := A[J,I] - A[J,K] * V[K]; 110 | A[J,I] := A[J,I] / D[I] 111 | end 112 | end; 113 | { STEP 5 } 114 | OUTPUT; 115 | close ( OUP ) 116 | end 117 | end. 118 | 119 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG066.PAS: -------------------------------------------------------------------------------- 1 | program ALG066; 2 | { CHOLESKI'S ALGORITHM 6.6 3 | 4 | To factor the positive definite n by n matrix A into LL**T, 5 | where L is lower triangular. 6 | 7 | INPUT: the dimension n; entries A(I,J), 1<=I, J<=n of A. 8 | 9 | OUTPUT: the entries L(I,J), 1<=J<=I, 1<=I<=n of L. 10 | 11 | the entries of U = L**T are U(I,J) = L(J,I), I<=J<=n, 1<=I<=n 12 | } 13 | var 14 | A : array [ 1..10, 1..10 ] of real; 15 | S : real; 16 | FLAG,N,I,J,K,NN,JJ,KK : integer; 17 | OK : boolean; 18 | AA : char; 19 | NAME : string [ 30 ]; 20 | INP,OUP : text; 21 | procedure INPUT; 22 | begin 23 | writeln('This is Choleski Factorization Method.'); 24 | writeln ('The array will be input from a text file in the order: '); 25 | writeln('A(1,1), A(1,2), ..., A(1,N), A(2,1), A(2,2), ..., A(2,N),'); 26 | writeln ('..., A(N,1), A(N,2), ..., A(N,N) '); writeln; 27 | write ('Place as many entries as desired on each line, but separate '); 28 | writeln ('entries with '); 29 | writeln ('at least one blank. '); 30 | writeln; writeln; 31 | writeln ('Has the input file been created? - enter Y or N. '); 32 | readln ( AA ); 33 | OK := false; 34 | if ( AA = 'Y' ) or ( AA = 'y' ) then 35 | begin 36 | writeln ('Input the file name in the form - drive:name.ext, '); 37 | writeln ('for example: A:DATA.DTA '); 38 | readln ( NAME ); 39 | assign ( INP, NAME ); 40 | reset ( INP ); 41 | OK := false; 42 | while ( not OK ) do 43 | begin 44 | writeln ('Input the dimension - an integer. '); 45 | readln ( N ); 46 | if ( N > 0 ) then 47 | begin 48 | for I := 1 to N do 49 | for J := 1 to N do read ( INP, A[I,J] ); 50 | OK := true; 51 | close ( INP ) 52 | end 53 | else writeln ('The number must be a positive integer. ') 54 | end 55 | end 56 | else writeln ('The program will end so the input file can be created. ') 57 | end; 58 | procedure OUTPUT; 59 | begin 60 | writeln ('Choice of output method: '); 61 | writeln ('1. Output to screen '); 62 | writeln ('2. Output to text file '); 63 | writeln ('Please enter 1 or 2. '); 64 | readln ( FLAG ); 65 | if ( FLAG = 2 ) then 66 | begin 67 | writeln ('Input the file name in the form - drive:name.ext, '); 68 | writeln('for example: A:OUTPUT.DTA'); 69 | readln ( NAME ); 70 | assign ( OUP, NAME ) 71 | end 72 | else assign ( OUP, 'CON' ); 73 | rewrite ( OUP ); 74 | writeln(OUP,'CHOLESKI FACTORIZATION'); 75 | writeln(OUP); 76 | writeln ( OUP, 'The matrix l output by rows: '); 77 | for I := 1 to N do 78 | begin 79 | for J := 1 to I do write ( OUP, '':2, A[I,J]:12:8 ); 80 | writeln ( OUP ) 81 | end; 82 | close ( OUP ) 83 | end; 84 | begin 85 | INPUT; 86 | if ( OK ) then 87 | begin 88 | { STEP 1 } 89 | A[1,1] := sqrt( A[1,1] ); 90 | { STEP 2 } 91 | for J := 2 to N do A[J,1] := A[J,1] / A[1,1]; 92 | { STEP 3 } 93 | NN := N - 1; 94 | for I := 2 to NN do 95 | begin 96 | { STEP 4 } 97 | KK := I - 1; 98 | S := 0.0; 99 | for K := 1 to KK do S := S - A[I,K] * A[I,K]; 100 | A[I,I] := sqrt( A[I,I] + S ); 101 | { STEP 5 } 102 | JJ := I + 1; 103 | for J := JJ to N do 104 | begin 105 | S := 0.0; 106 | KK := I - 1; 107 | for K := 1 to KK do S := S - A[J,K] * A[I,K]; 108 | A[J,I] := ( A[J,I] + S ) / A[I,I] 109 | end 110 | end; 111 | { STEP 6 } 112 | S := 0.0; 113 | for K := 1 to NN do S := S - A[N,K] * A[N,K]; 114 | A[N,N] := sqrt( A[N,N] + S ); 115 | { STEP 7 } 116 | OUTPUT 117 | end 118 | end. 119 | 120 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG067.PAS: -------------------------------------------------------------------------------- 1 | program ALG067; 2 | { CROUT REDUCTION FOR TRIDIAGONAL LINEAR SYSTEMS ALGORITHM 6.7 3 | 4 | To solve the n x n linear system 5 | 6 | E1: A[1,1] X[1] + A[1,2] X[2] = A[1,n+1] 7 | E2: A[2,1] X[1] + A[2,2] X[2] + A[2,3] X[3] = A[2,n+1] 8 | : 9 | . 10 | E(n): A[n,n-1] X[n-1] + A[n,n] X[n] = A[n,n+1] 11 | 12 | INPUT: the dimension n; the entries of A. 13 | 14 | OUTPUT: the solution X(1), ..., X(N). 15 | } 16 | var 17 | A,B,C,BB,Z,X : array [ 1..10 ] of real; 18 | FLAG,N,I,J,NN,II : integer; 19 | OK : boolean; 20 | AA : char; 21 | NAME : string [ 30 ]; 22 | INP,OUP : text; 23 | procedure INPUT; 24 | begin 25 | writeln('This is Crout Method for tridiagonal linear systems.'); 26 | writeln ('The array will be input from a text file in the order: '); 27 | write ('all diagonal entries, all lower sub-diagonal entries, all '); 28 | writeln ('upper sub-diagonal '); 29 | writeln ('entries, inhomogeneous term. '); writeln; 30 | write ('Place as many entries as desired on each line, but separate '); 31 | writeln ('entries with '); 32 | writeln ('at least one blank. '); 33 | writeln; writeln; 34 | writeln ('Has the input file been created? - enter Y or N. '); 35 | readln ( AA ); 36 | OK := false; 37 | if ( AA = 'Y' ) or ( AA = 'y' ) then 38 | begin 39 | writeln ('Input the file name in the form - drive:name.ext, '); 40 | writeln ('for example: A:DATA.DTA '); 41 | readln ( NAME ); 42 | assign ( INP, NAME ); 43 | reset ( INP ); 44 | OK := false; 45 | while ( not OK ) do 46 | begin 47 | writeln ('Input the number of equations - an integer. '); 48 | readln ( N ); 49 | if ( N > 0 ) then 50 | begin 51 | { A(I,I) is stored in A(I), 1 <= I <= n } 52 | for I := 1 to N do read ( INP, A[I] ); 53 | { the lower sub-diagonal A(I,I-1) is stored 54 | in B(I), 2 <= I <= n } 55 | for I := 2 to N do read ( INP, B[I] ); 56 | { the upper sub-diagonal A(I,I+1) is stored 57 | in C(I), 1 <= I <= n-1 } 58 | NN := N - 1; 59 | for I := 1 to NN do read ( INP, C[I] ); 60 | { A(I,N+1) is stored in BB(I), 1 <= I <= n } 61 | for I := 1 to N do read ( INP, BB[I] ); 62 | OK := true; 63 | close ( INP ) 64 | end 65 | else writeln ('The number must be a positive integer. ') 66 | end 67 | end 68 | else writeln ('The program will end so the input file can be created. ') 69 | end; 70 | procedure OUTPUT; 71 | begin 72 | writeln ('Choice of output method: '); 73 | writeln ('1. Output to screen '); 74 | writeln ('2. Output to text file '); 75 | writeln ('Please enter 1 or 2. '); 76 | readln ( FLAG ); 77 | if ( FLAG = 2 ) then 78 | begin 79 | writeln ('Input the file name in the form - drive:name.ext, '); 80 | writeln('for example: A:OUTPUT.DTA'); 81 | readln ( NAME ); 82 | assign ( OUP, NAME ) 83 | end 84 | else assign ( OUP, 'CON' ); 85 | rewrite ( OUP ); 86 | writeln(OUP,'CROUT METHOD FOR TRIDIAGONAL LINEAR SYSTEMS'); 87 | writeln(OUP); 88 | writeln ( OUP, 'The solution is '); 89 | for I := 1 to N do write ( OUP, '':2, X[I]:12:8 ); 90 | writeln(OUP); 91 | close ( OUP ) 92 | end; 93 | begin 94 | INPUT; 95 | if ( OK ) then 96 | begin 97 | { STEPS 1-3 set up and solve LZ = B } 98 | { STEP 1 } 99 | { the entries of U overwrite C and 100 | the entries of L overwrite A } 101 | C[1] := C[1] / A[1]; 102 | Z[1] := BB[1] / A[1]; 103 | { STEP 2 } 104 | for I := 2 to NN do 105 | begin 106 | A[I] := A[I] - B[I] * C[I-1]; 107 | C[I] := C[I] / A[I]; 108 | Z[I] := (BB[I]-B[I]*Z[I-1])/A[I] 109 | end; 110 | { STEP 3 } 111 | A[N] := A[N] - B[N] * C[N-1]; 112 | Z[N] := (BB[N]-B[N]*Z[N-1])/A[N]; 113 | { STEP 4 } 114 | { STEPS 4, 5 solve UX = Z } 115 | X[N] := Z[N]; 116 | { STEP 5 } 117 | for II := 1 to NN do 118 | begin 119 | I := NN - II + 1; 120 | X[I] := Z[I] - C[I] * X[I+1] 121 | end; 122 | { STEP 6 } 123 | OUTPUT 124 | end 125 | end. 126 | 127 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG071.PAS: -------------------------------------------------------------------------------- 1 | program ALG071; 2 | { JACOBI ITERATIVE ALGORITHM 7.1 3 | 4 | To solve Ax = b given an initial approximation x(0). 5 | 6 | INPUT: the number of equations and unknowns n; the entries 7 | A(I,J), 1<=I, J<=n, of the matrix A; the entries 8 | B(I), 1<=I<=n, of the inhomogeneous term b; the 9 | entries XO(I), 1<=I<=n, of x(0); tolerance TOL; 10 | maximum number of iterations N. 11 | 12 | OUTPUT: the approximate solution X(1),...,X(n) or a message 13 | that the number of iterations was exceeded. 14 | } 15 | var 16 | INP,OUP : text; 17 | A : array [ 1..10, 1..11 ] of real; 18 | X1,X2 : array [ 1..10 ] of real; 19 | S,ERR,TOL : real; 20 | FLAG,N,I,J,NN,K : integer; 21 | OK : boolean; 22 | AA : char; 23 | NAME : string [ 30 ]; 24 | procedure INPUT; 25 | begin 26 | writeln('This is the Jacobi Method for Linear Systems.'); 27 | OK := false; 28 | writeln ('The array will be input from a text file in the order: '); 29 | writeln('A(1,1), A(1,2), ..., A(1,n+1), A(2,1), A(2,2), ..., A(2,n+1),'); 30 | write ('..., A(n,1), '); 31 | writeln ('A(n,2), ..., A(n,n+1) '); writeln; 32 | write ('Place as many entries as desired on each line, but separate '); 33 | writeln ('entries with '); 34 | writeln ('at least one blank.'); 35 | writeln ('The initial approximation should follow in same format.' ); 36 | writeln; writeln; 37 | writeln ('Has the input file been created? - enter Y or N. '); 38 | readln ( AA ); 39 | if ( AA = 'Y' ) or ( AA = 'y' ) then 40 | begin 41 | writeln ('Input the file name in the form - drive:name.ext, '); 42 | writeln ('for example: A:DATA.DTA '); 43 | readln ( NAME ); 44 | assign ( INP, NAME ); 45 | reset ( INP ); 46 | OK := false; 47 | while ( not OK ) do 48 | begin 49 | writeln ('Input the number of equations - an integer. '); 50 | readln ( N ); 51 | if ( N > 0 ) then 52 | begin 53 | for I := 1 to N do 54 | for J := 1 to N + 1 do read ( INP, A[I,J] ); 55 | for I := 1 to N do read ( INP, X1[I]); 56 | { use X1 for XO } 57 | OK := true; 58 | close ( INP ) 59 | end 60 | else writeln ('The number must be a positive integer. ') 61 | end; 62 | OK := false; 63 | while ( not OK) do 64 | begin 65 | writeln ('Input the tolerance.'); 66 | readln ( TOL ); 67 | if (TOL > 0) then OK := true 68 | else writeln('Tolerance must be a positive number.') 69 | end; 70 | OK := false; 71 | while ( not OK) do 72 | begin 73 | writeln('Input maximum number of iterations.'); 74 | readln ( NN ); 75 | { use NN for N } 76 | if (NN > 0) then OK := true 77 | else writeln('Number must be a positive integer.') 78 | end 79 | end 80 | else writeln ('The program will end so the input file can be created. ') 81 | end; 82 | procedure OUTPUT; 83 | begin 84 | writeln ('Choice of output method: '); 85 | writeln ('1. Output to screen '); 86 | writeln ('2. Output to text file '); 87 | writeln ('Please enter 1 or 2. '); 88 | readln ( FLAG ); 89 | if ( FLAG = 2 ) then 90 | begin 91 | writeln ('Input the file name in the form - drive:name.ext, '); 92 | writeln('for example: A:OUTPUT.DTA'); 93 | readln ( NAME ); 94 | assign ( OUP, NAME ) 95 | end 96 | else assign ( OUP, 'CON' ); 97 | rewrite ( OUP ); 98 | writeln(OUP,'JACOBI ITERATIVE METHOD FOR LINEAR SYSTEMS'); 99 | writeln ( OUP ); 100 | writeln ( OUP, 'The solution vector is : '); 101 | for I := 1 to N do write ( OUP, X2[I]:12:8 ); 102 | writeln ( OUP ); writeln ( OUP, 'using ',K,' iterations '); 103 | writeln ( OUP, 'with Tolerance',TOL,' in infinity-norm'); 104 | close ( OUP ) 105 | end; 106 | begin 107 | INPUT; 108 | if ( OK ) then 109 | begin 110 | { STEP 1 } 111 | K := 1; 112 | OK := false; 113 | { STEP 2 } 114 | while ( not OK ) and ( K <= NN ) do 115 | begin 116 | { err is used to test accuracy - it measures the 117 | infinity-norm } 118 | ERR := 0.0; 119 | { STEP 3 } 120 | for I := 1 to N do 121 | begin 122 | S := 0.0; 123 | for J := 1 to N do S := S - A[I,J] * X1[J]; 124 | S := ( S + A[I,N + 1] ) / A[I,I]; 125 | if (abs(S) > ERR) then ERR := abs(S); 126 | { use X2 for X } 127 | X2[I] := X1[I] + S 128 | end; 129 | { STEP 4 } 130 | if ( ERR <= TOL ) then OK := true 131 | { process is complete } 132 | else 133 | begin 134 | { STEP 5 } 135 | K := K + 1; 136 | { STEP 6 } 137 | FOR I := 1 TO N DO X1[I] := X2[I] 138 | end 139 | end; 140 | if ( not OK ) then writeln 141 | ('Maximum Number of Iterations Exceeded ') 142 | { STEP 7 } 143 | { procedure completed unsuccessfully } 144 | else OUTPUT 145 | end 146 | end. 147 | 148 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG072.PAS: -------------------------------------------------------------------------------- 1 | program ALG072; 2 | { GAUSS-SEIDEL ITERATAIVE TECHNIQUE ALGORITHM 7.2 3 | 4 | To solve Ax = b given an initial approximation x(0). 5 | 6 | INPUT: the number of equations and unknowns n; the entries 7 | A(I,J), 1<=I, J<=n, of the matrix A; the entries 8 | B(I), 1<=I<=n, of the inhomogeneous term b; the\ 9 | entries XO(I), 1<=I<=n, of x(0); tolerance TOL; 10 | maximum number of iterations N. 11 | 12 | OUTPUT: the approximate solution X(1),...,X(n) or a message 13 | that the number of iterations was exceeded. 14 | } 15 | var 16 | INP,OUP : text; 17 | A : array [ 1..10, 1..11 ] of real; 18 | X1 : array [ 1..10 ] of real; 19 | S,ERR,TOL : real; 20 | FLAG,N,I,J,NN,K : integer; 21 | OK : boolean; 22 | AA : char; 23 | NAME : string [ 30 ]; 24 | procedure INPUT; 25 | begin 26 | writeln('This is the Gauss-Seidel Method for Linear Systems.'); 27 | OK := false; 28 | writeln ('The array will be input from a text file in the order: '); 29 | writeln('A(1,1), A(1,2), ..., A(1,n+1), A(2,1), A(2,2), ..., A(2,n+1),'); 30 | write ('..., A(n,1), '); 31 | writeln ('A(n,2), ..., A(n,n+1) '); writeln; 32 | write ('Place as many entries as desired on each line, but separate '); 33 | writeln ('entries with '); 34 | writeln ('at least one blank.'); 35 | writeln ('The initial approximation should follow in same format.' ); 36 | writeln; writeln; 37 | writeln ('Has the input file been created? - enter Y or N. '); 38 | readln ( AA ); 39 | if ( AA = 'Y' ) or ( AA = 'y' ) then 40 | begin 41 | writeln ('Input the file name in the form - drive:name.ext, '); 42 | writeln ('for example: A:DATA.DTA '); 43 | readln ( NAME ); 44 | assign ( INP, NAME ); 45 | reset ( INP ); 46 | OK := false; 47 | while ( not OK ) do 48 | begin 49 | writeln ('Input the number of equations - an integer. '); 50 | readln ( N ); 51 | if ( N > 0 ) then 52 | begin 53 | for I := 1 to N do 54 | for J := 1 to N + 1 do read ( INP, A[I,J] ); 55 | for I := 1 to N do read ( INP, X1[I]); 56 | { use X1 for XO } 57 | OK := true; 58 | close ( INP ) 59 | end 60 | else writeln ('The number must be a positive integer. ') 61 | end; 62 | OK := false; 63 | while ( not OK) do 64 | begin 65 | writeln ('Input the tolerance.'); 66 | readln ( TOL ); 67 | if (TOL > 0) then OK := true 68 | else writeln('Tolerance must be a positive number.') 69 | end; 70 | OK := false; 71 | while ( not OK) do 72 | begin 73 | writeln('Input maximum number of iterations.'); 74 | readln ( NN ); 75 | { use NN for N } 76 | if (NN > 0) then OK := true 77 | else writeln('Number must be a positive integer.') 78 | end 79 | end 80 | else writeln ('The program will end so the input file can be created. ') 81 | end; 82 | procedure OUTPUT; 83 | begin 84 | writeln ('Choice of output method: '); 85 | writeln ('1. Output to screen '); 86 | writeln ('2. Output to text file '); 87 | writeln ('Please enter 1 or 2. '); 88 | readln ( FLAG ); 89 | if ( FLAG = 2 ) then 90 | begin 91 | writeln ('Input the file name in the form - drive:name.ext, '); 92 | writeln('for example: A:OUTPUT.DTA'); 93 | readln ( NAME ); 94 | assign ( OUP, NAME ) 95 | end 96 | else assign ( OUP, 'CON' ); 97 | rewrite ( OUP ); 98 | writeln(OUP,'GAUSS-SEIDEL METHOD FOR LINEAR SYSTEMS'); 99 | writeln ( OUP ); 100 | writeln ( OUP, 'The solution vector is : '); 101 | for I := 1 to N do write ( OUP, X1[I]:12:8); 102 | writeln ( OUP ); writeln ( OUP, 'using ',K,' iterations '); 103 | writeln ( OUP, 'with Tolerance',TOL,' in infinity-norm'); 104 | close ( OUP ) 105 | end; 106 | begin 107 | INPUT; 108 | if ( OK ) then 109 | begin 110 | { STEP 1 } 111 | K := 1; 112 | OK := false; 113 | { STEP 2 } 114 | while ( not OK ) and ( K <= NN ) do 115 | begin 116 | { ERR is used to test accuracy - it measures the 117 | infinity-norm } 118 | ERR := 0.0; 119 | { STEP 3 } 120 | for I := 1 to N do 121 | begin 122 | S := 0.0; 123 | for J := 1 to N do S := S - A[I,J] * X1[J]; 124 | S := ( S + A[I,N + 1] ) / A[I,I]; 125 | if (abs(S) > ERR) then ERR := abs(S); 126 | X1[I] := X1[I] + S 127 | end; 128 | { STEP 4 } 129 | if ( ERR <= TOL ) then OK := true 130 | { process is complete } 131 | else 132 | begin 133 | { STEP 5 } 134 | K := K + 1 135 | { STEP 6 - is not used since only one vector is required } 136 | end 137 | end; 138 | if ( not OK ) then writeln 139 | ('Maximum Number of Iterations Exceeded. ') 140 | { STEP 7 } 141 | { procedure completed unsuccessfully } 142 | else OUTPUT 143 | end 144 | end. 145 | 146 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG073.PAS: -------------------------------------------------------------------------------- 1 | program ALG073; 2 | { SOR ALGORITHM 7.3 3 | 4 | To solve Ax = b given the parameter w and an initial approximation 5 | x(0): 6 | 7 | INPUT: the number of equations and unknowns n; the entries 8 | A(I,J), 1<=I, J<=n, of the matrix A; the entries 9 | B(I), 1<=I<=n, of the inhomogeneous term b; the 10 | entries XO(I), 1<=I<=n, of x(0); the parameter w; 11 | tolerance TOL; maximum number of iterations N. 12 | 13 | OUTPUT: the approximate solution X(1),...,X(N) or a message 14 | that the number of iterations was exceeded. 15 | } 16 | var 17 | INP,OUP : text; 18 | A : array [ 1..10, 1..11 ] of real; 19 | X1 : array [ 1..10 ] of real; 20 | W,S,ERR,TOL : real; 21 | FLAG,N,I,J,NN,K : integer; 22 | OK : boolean; 23 | AA : char; 24 | NAME : string [ 30 ]; 25 | procedure INPUT; 26 | begin 27 | writeln('This is the SOR Method for Linear Systems.'); 28 | OK := false; 29 | writeln ('The array will be input from a text file in the order: '); 30 | writeln('A(1,1), A(1,2), ..., A(1,n+1), A(2,1), A(2,2), ..., A(2,n+1),'); 31 | write ('..., A(n,1), '); 32 | writeln ('A(n,2), ..., A(n,n+1) '); writeln; 33 | write ('Place as many entries as desired on each line, but separate '); 34 | writeln ('entries with '); 35 | writeln ('at least one blank.'); 36 | writeln ('The initial approximation should follow in same format.' ); 37 | writeln; writeln; 38 | writeln ('Has the input file been created? - enter Y or N. '); 39 | readln ( AA ); 40 | if ( AA = 'Y' ) or ( AA = 'y' ) then 41 | begin 42 | writeln ('Input the file name in the form - drive:name.ext, '); 43 | writeln ('for example: A:DATA.DTA '); 44 | readln ( NAME ); 45 | assign ( INP, NAME ); 46 | reset ( INP ); 47 | OK := false; 48 | while ( not OK ) do 49 | begin 50 | writeln ('Input the number of equations - an integer. '); 51 | readln ( N ); 52 | if ( N > 0 ) then 53 | begin 54 | for I := 1 to N do 55 | for J := 1 to N + 1 do read ( INP, A[I,J] ); 56 | for I := 1 to N do read ( INP, X1[I]); 57 | { use X1 for XO } 58 | OK := true; 59 | close ( INP ) 60 | end 61 | else writeln ('The number must be a positive integer. ') 62 | end; 63 | OK := false; 64 | while ( not OK) do 65 | begin 66 | writeln ('Input the tolerance.'); 67 | readln ( TOL ); 68 | if (TOL > 0) then OK := true 69 | else writeln('Tolerance must be a positive number.') 70 | end; 71 | OK := false; 72 | while ( not OK) do 73 | begin 74 | writeln('Input maximum number of iterations.'); 75 | readln ( NN ); 76 | { use NN for N } 77 | if (NN > 0) then OK := true 78 | else writeln('Number must be a positive integer.') 79 | end; 80 | writeln ('Input parameter w (omega)'); 81 | readln ( W ) 82 | { use W for omega } 83 | end 84 | else writeln ('The program will end so the input file can be created. ') 85 | end; 86 | procedure OUTPUT; 87 | begin 88 | writeln ('Choice of output method: '); 89 | writeln ('1. Output to screen '); 90 | writeln ('2. Output to text file '); 91 | writeln ('Please enter 1 or 2. '); 92 | readln ( FLAG ); 93 | if ( FLAG = 2 ) then 94 | begin 95 | writeln ('Input the file name in the form - drive:name.ext, '); 96 | writeln('for example: A:OUTPUT.DTA'); 97 | readln ( NAME ); 98 | assign ( OUP, NAME ) 99 | end 100 | else assign ( OUP, 'CON' ); 101 | rewrite ( OUP ); 102 | writeln(OUP,'SOR ITERATIVE METHOD FOR LINEAR SYSTEMS'); 103 | writeln ( OUP ); 104 | writeln ( OUP, 'The solution vector is : '); 105 | for I := 1 to N do write ( OUP, X1[I]:12:8 ); 106 | writeln ( OUP ); writeln ( OUP, 'using ',K,' iterations with '); 107 | writeln ( OUP, 'Tolerance', TOL,' in infinity-norm and Parameter',W ); 108 | close ( OUP ) 109 | end; 110 | begin 111 | INPUT; 112 | if ( OK ) then 113 | begin 114 | { STEP 1 } 115 | K := 1; 116 | OK := false; 117 | { STEP 2 } 118 | while ( not OK ) and ( K <= NN ) do 119 | begin 120 | { err is used to test accuracy - it measures the 121 | infinity-norm } 122 | ERR := 0.0; 123 | { STEP 3 } 124 | for I := 1 to N do 125 | begin 126 | S := 0.0; 127 | for J := 1 to N do S := S - A[I,J] * X1[J]; 128 | S := W * ( S + A[I,N + 1] ) /A[I,I]; 129 | if (abs(S) > ERR) then ERR := abs(S); 130 | { X is not used since only one vector is needed } 131 | X1[I] := X1[I] + S 132 | end; 133 | { STEP 4 } 134 | if ( ERR <= TOL ) then OK := true 135 | { process is complete } 136 | else 137 | { STEP 5 } 138 | K := K + 1 139 | { STEP 6 - is not used since only one vector is required } 140 | end; 141 | if ( not OK ) then writeln 142 | ('Maximum Number of Iterations Exceeded. ') 143 | { STEP 7 } 144 | { procedure completed unsuccessfully } 145 | else OUTPUT 146 | end 147 | end. 148 | 149 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG111.PAS: -------------------------------------------------------------------------------- 1 | program ALG111; 2 | { 3 | LINEAR SHOOTING ALGORITHM 11.1 4 | 5 | To approximate the solution of the boundary-value problem 6 | 7 | -Y'' + P(X)Y' + Q(X)Y + R(X) = 0, A<=X<=B, Y(A)=ALPHA, Y(B)=BETA: 8 | 9 | 10 | INPUT: Endpoints A,B; boundary conditions ALPHA, BETA; number of 11 | subintervals N. 12 | 13 | OUTPUT: Approximations W(1,I) to Y(X(I)); W(2,I) to Y'(X(I)) 14 | for each I=0,1,...,N. 15 | 16 | } 17 | var 18 | U,V : array [ 1..2, 1..25 ] of real; 19 | T,A,B,ALPHA,BETA,X,H,U1,U2,V1,V2,W1,W2,Z : real; 20 | K11,K12,K21,K22,K31,K32,K41,K42 : real; 21 | N,FLAG,I : integer; 22 | OK : boolean; 23 | AA : char; 24 | NAME : string [ 30 ]; 25 | OUP : text; 26 | { Change functions P, Q, R for a new problem } 27 | function P ( X : real ) : real; 28 | begin 29 | P := -2/X 30 | end; 31 | function Q ( X : real ) : real; 32 | begin 33 | Q := 2/(X*X) 34 | end; 35 | function R ( X : real ) : real; 36 | begin 37 | R := sin(ln(X))/(X*X) 38 | end; 39 | procedure INPUT; 40 | begin 41 | writeln('This is the Linear Shooting Method.'); 42 | OK := false; 43 | writeln ('Have the functions P, Q, and R been created immediately '); 44 | writeln ('preceding the INPUT procedure? '); 45 | writeln ('Answer Y or N. '); 46 | readln ( AA ); 47 | if ( (AA = 'Y') or (AA = 'y') ) then 48 | begin 49 | while ( not OK ) do 50 | begin 51 | write ('Input left and right endpoints '); 52 | writeln('separated by blank. '); 53 | readln ( A, B ); 54 | if ( A >= B ) then 55 | writeln('Left endpoint must be less than right endpoint.') 56 | else OK := true 57 | end; 58 | writeln ('Input Y(',A,'). '); 59 | readln ( ALPHA ); 60 | writeln ('Input Y(',B,'). '); 61 | readln ( BETA ); 62 | OK := false; 63 | while ( not OK ) do 64 | begin 65 | write ('Input a positive integer for the number of '); 66 | writeln ('subintervals. '); 67 | readln ( N ); 68 | if ( N <= 0 ) then 69 | writeln ('Number must be a positive integer. ') 70 | else OK := true 71 | end 72 | end 73 | else writeln ('The program will end so that P, Q, R can be created. ') 74 | end; 75 | procedure OUTPUT; 76 | begin 77 | writeln ('Choice of output method: '); 78 | writeln ('1. Output to screen '); 79 | writeln ('2. Output to text file '); 80 | writeln ('Please enter 1 or 2. '); 81 | readln ( FLAG ); 82 | if ( FLAG = 2 ) then 83 | begin 84 | writeln ('Input the file name in the form - drive:name.ext, '); 85 | writeln('for example: A:OUTPUT.DTA'); 86 | readln ( NAME ); 87 | assign ( OUP, NAME ) 88 | end 89 | else assign ( OUP, 'CON' ); 90 | rewrite ( OUP ); 91 | writeln(OUP,'LINEAR SHOOTING METHOD'); 92 | writeln(OUP); 93 | write ( OUP, 'I':3,'X(I)':12,'W(1,I)':12,'W(2,I)':12); 94 | writeln ( OUP ); 95 | end; 96 | begin 97 | INPUT; 98 | if ( OK ) then 99 | begin 100 | OUTPUT; 101 | { STEP 1 } 102 | H := ( B - A ) / N; 103 | U1 := ALPHA; 104 | U2 := 0.0; 105 | V1 := 0.0; 106 | V2 := 1.0; 107 | { STEP 2 } 108 | for I := 1 to N do 109 | begin 110 | { STEP 3 } 111 | X := A + ( I - 1.0 ) * H; 112 | T := X + 0.5 * H; 113 | { STEP 4 } 114 | K11 := H * U2; 115 | K12 := H * ( P( X ) * U2 + Q( X ) * U1 + R( X ) ); 116 | K21 := H * ( U2 + 0.5 * K12 ); 117 | K22 := H * ( P( T ) * ( U2 + 0.5 * K12 ) + Q( T ) * 118 | ( U1 + 0.5 * K11 ) + R( T ) ); 119 | K31 := H * ( U2 + 0.5 * K22 ); 120 | K32 := H * ( P( T ) * ( U2 + 0.5 * K22 ) + Q( T ) * 121 | ( U1 + 0.5 * K21 ) + R( T ) ); 122 | T := X + H; 123 | K41 := H * ( U2 + K32 ); 124 | K42 := H * ( P( T ) * ( U2 + K32 ) + Q(T) * ( U1 + K31 ) + 125 | R( T ) ); 126 | U1 := U1 + ( K11 + 2.0 * ( K21 + K31 ) + K41 ) / 6.0; 127 | U2 := U2 + ( K12 + 2.0 * ( K22 + K32 ) + K42 ) / 6.0; 128 | K11 := H * V2; 129 | K12 := H * ( P( X ) * V2 + Q( X ) * V1 ); 130 | T := X + 0.5 * H; 131 | K21 := H * ( V2 + 0.5 * K12 ); 132 | K22 := H * ( P( T ) * ( V2 + 0.5 * K12 ) + Q( T ) * 133 | ( V1 + 0.5 * K11 ) ); 134 | K31 := H * ( V2 + 0.5 * K22 ); 135 | K32 := H * ( P( T ) * ( V2 + 0.5 * K22 ) + Q( T ) * 136 | ( V1 + 0.5 * K21 ) ); 137 | T := X + H; 138 | K41 := H * ( V2 + K32 ); 139 | K42 := H * ( P( T ) * ( V2 + K32 ) + Q(T) * ( V1 + K31 )); 140 | V1 := V1 + ( K11 + 2.0 * ( K21 + K31 ) + K41 ) / 6.0; 141 | V2 := V2 + ( K12 + 2.0 * ( K22 + K32 ) + K42 ) / 6.0; 142 | U[1,I] := U1; 143 | U[2,I] := U2; 144 | V[1,I] := V1; 145 | V[2,I] := V2 146 | end; 147 | { STEP 5 } 148 | W1 := ALPHA; 149 | Z := ( BETA - U[1,N] ) / V[1,N]; 150 | X := A; 151 | I := 0; 152 | writeln (OUP,I:3,X:12:8,W1:12:8,Z:12:8); 153 | { STEP 6 } 154 | for I := 1 to N do 155 | begin 156 | X := A + I * H; 157 | W1 := U[1,I] + Z * V[1,I]; 158 | W2 := U[2,I] + Z * V[2,I]; 159 | writeln (OUP,I:3,X:12:8,W1:12:8,W2:12:8); 160 | end; 161 | close (oup) 162 | end 163 | { STEP 7 } 164 | end. 165 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG113.PAS: -------------------------------------------------------------------------------- 1 | program ALG113; 2 | { 3 | LINEAR FINITE-DIFFERENCE ALGORITHM 11.3 4 | 5 | To approximate the solution of the boundary-value problem 6 | 7 | Y'' = P(X)Y' + Q(X)Y + R(X), A<=X<=B, Y(A) = ALPHA, Y(B) = BETA: 8 | 9 | INPUT: Endpoints A, B; boundary conditions ALPHA, BETA; 10 | integer N. 11 | 12 | OUTPUT: Approximations W(I) to Y(X(I)) for each I=0,1,...,N+1. 13 | } 14 | var 15 | A,B,C,D,L,U,Z,W : array [ 1..24 ] of real; 16 | AA,BB,ALPHA,BETA,X,H : real; 17 | N,FLAG,I,M,J : integer; 18 | OK : boolean; 19 | AB : char; 20 | NAME : string [ 30 ]; 21 | OUP : text; 22 | { Change functions P, Q and R for a new problem } 23 | function P ( X : real ) : real; 24 | begin 25 | P := -2/X 26 | end; 27 | function Q ( X : real ) : real; 28 | begin 29 | Q := 2/(X*X) 30 | end; 31 | function R ( X : real ) : real; 32 | begin 33 | R := sin(ln(X))/(X*X) 34 | end; 35 | procedure INPUT; 36 | begin 37 | writeln('This is the Linear Finite-Difference Method.'); 38 | OK := false; 39 | writeln ('Have the functions P, Q and R been created immediately'); 40 | writeln ('preceding the INPUT procedure? '); 41 | writeln ('Answer Y or N. '); 42 | readln ( AB ); 43 | if ( AB = 'Y' ) or ( AB = 'y' ) then 44 | begin 45 | while ( not OK ) do 46 | begin 47 | write('Input left and right endpoints '); 48 | writeln('separated by blank. '); 49 | readln ( AA, BB ); 50 | if ( AA >= BB ) then 51 | writeln ('Left endpoint must be less than right endpoint.') 52 | else OK := true 53 | end; 54 | writeln ('Input Y(',AA,'). '); 55 | readln ( ALPHA ); 56 | writeln ('Input Y(',BB,'). '); 57 | readln ( BETA ); 58 | OK := false; 59 | while ( not OK ) do 60 | begin 61 | writeln ('Input an integer > 1 for the number of '); 62 | writeln ('subintervals. Note that h = (b-a)/(n+1) '); 63 | readln ( N ); 64 | if ( N <= 1 ) then 65 | writeln ('Number must exceed 1. ') 66 | else OK := true 67 | end 68 | end 69 | else writeln ('The program will end so that P, Q, R can be created. ') 70 | end; 71 | procedure OUTPUT; 72 | begin 73 | writeln ('Choice of output method: '); 74 | writeln ('1. Output to screen '); 75 | writeln ('2. Output to text file '); 76 | writeln ('Please enter 1 or 2. '); 77 | readln ( FLAG ); 78 | if ( FLAG = 2 ) then 79 | begin 80 | writeln ('Input the file name in the form - drive:name.ext, '); 81 | writeln('for example: A:OUTPUT.DTA'); 82 | readln ( NAME ); 83 | assign ( OUP, NAME ) 84 | end 85 | else assign ( OUP, 'CON' ); 86 | rewrite ( OUP ); 87 | writeln(OUP,'LINEAR FINITE DIFFERENCE METHOD'); 88 | writeln(OUP); 89 | write ( OUP, 'I':3,'X(I)':14,'W(I)':14); 90 | writeln ( OUP ); 91 | end; 92 | begin 93 | INPUT; 94 | if ( OK ) then 95 | begin 96 | OUTPUT; 97 | { STEP 1 } 98 | H := ( BB - AA ) / ( N + 1.0 ); 99 | X := AA + H; 100 | A[1] := 2.0 + H * H * Q( X ); 101 | B[1] := -1.0 + 0.5 * H * P( X ); 102 | D[1] := -H*H*R(X)+(1.0+0.5*H*P(X))*ALPHA; 103 | M := N - 1; 104 | { STEP 2 } 105 | for I := 2 to M do 106 | begin 107 | X := AA + I * H; 108 | A[I] := 2.0 + H * H * Q( X ); 109 | B[I] := -1.0 + 0.5 * H * P( X ); 110 | C[I] := -1.0 - 0.5 * H * P( X ); 111 | D[I] := -H * H * R( X ) 112 | end; 113 | { STEP 3 } 114 | X := BB - H; 115 | A[N] := 2.0 + H * H * Q( X ); 116 | C[N] := -1.0 - 0.5 * H * P( X ); 117 | D[N] := -H*H*R(X)+(1.0-0.5*H*P(X))*BETA; 118 | { STEP 4 119 | STEPS 4 through 8 solve a triagiagonal linear system using 120 | Algorithm 6.7 } 121 | L[1] := A[1]; 122 | U[1] := B[1] / A[1]; 123 | Z[1] := D[1] / L[1]; 124 | { STEP 5 } 125 | for I := 2 to M do 126 | begin 127 | L[I] := A[I] - C[I] * U[I-1]; 128 | U[I] := B[I] / L[I]; 129 | Z[I] := (D[I] - C[I] * Z[I-1])/L[I]; 130 | end; 131 | { STEP 6 } 132 | L[N] := A[N] - C[N] * U[N-1]; 133 | Z[N] := (D[N] - C[N] * Z[N-1])/L[N]; 134 | { STEP 7 } 135 | W[N] := Z[N]; 136 | { STEP 8 } 137 | for J := 1 to M do 138 | begin 139 | I := N - J; 140 | W[I] := Z[I] - U[I] * W[I+1] 141 | end; 142 | I := 0; 143 | { STEP 9 } 144 | writeln (OUP,I:3,AA:14:8,ALPHA:14:8); 145 | for I := 1 to N do 146 | begin 147 | X := AA + I * H; 148 | writeln(OUP,I:3,X:14:8,W[I]:14:8) 149 | end; 150 | I := N + 1; 151 | writeln(OUP,I:3,BB:14:8,BETA:14:8); 152 | { STEP 10 } 153 | close( OUP ) 154 | end 155 | end. 156 | 157 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG122.PAS: -------------------------------------------------------------------------------- 1 | program ALG122; 2 | { 3 | HEAT EQUATION BACKWARD-DIFFERENCE ALGORITHM 12.2 4 | 5 | To approximate the solution to the parabolic partial-differential 6 | equation subject to the boundary conditions 7 | u(0,t) = u(l,t) = 0, 0 < t < T = max t, 8 | and the initial conditions 9 | u(x,0) = F(x), 0 <= x <= l: 10 | 11 | INPUT: endpoint l; maximum time T; constant ALPHA; integers m, N. 12 | 13 | OUTPUT: approximations W(I,J) to u(x(I),t(J)) for each 14 | I = 1, ..., m-1 and J = 1, ..., N. 15 | } 16 | var 17 | W,L,U,Z : array [ 1..25 ] of real; 18 | FT,FX,ALPHA,H,K,VV,T,X : real; 19 | N,M,M1,M2,N1,FLAG,I1,I,J : integer; 20 | OK : boolean; 21 | AA : char; 22 | NAME : string [ 30 ]; 23 | OUP : text; 24 | { Change F for a new problem } 25 | function F( X : real ) : real; 26 | begin 27 | F := sin( PI * X ) 28 | end; 29 | procedure INPUT; 30 | begin 31 | writeln('This is the Backward-Difference Method for Heat Equation.'); 32 | writeln ('Has the function F been created immediately '); 33 | writeln ('preceding the INPUT procedure? Answer Y or N. '); 34 | readln ( AA ); 35 | if ( AA = 'Y' ) or ( AA = 'y' ) then 36 | begin 37 | writeln ('The lefthand endpoint on the X-axis is 0. '); 38 | OK := false; 39 | while ( not OK ) do 40 | begin 41 | writeln ('Input the righthand endpoint on the X-axis. '); 42 | readln ( FX ); 43 | if ( FX <= 0.0 ) then 44 | writeln ('Must be positive number. ') 45 | else 46 | OK := true 47 | end; 48 | OK := false; 49 | while ( not OK ) do 50 | begin 51 | writeln ('Input the maximum value of the time variable T. '); 52 | readln ( FT ); 53 | if ( FT <= 0.0 ) then 54 | writeln ('Must be positive number. ') 55 | else 56 | Ok := true 57 | end; 58 | writeln ('Input the constant alpha. '); 59 | readln ( ALPHA ); 60 | OK := false; 61 | while ( not OK ) do 62 | begin 63 | writeln('Input integer m = number of intervals on X-axis'); 64 | write ('and N = number of time intervals '); 65 | writeln ('- separated by a blank. '); 66 | writeln('Note that m should be 3 or larger.'); 67 | readln ( M, N ); 68 | if ( ( M <= 2 ) or ( N <= 0 ) ) then 69 | writeln ('Numbers not in the correct range. ') 70 | else 71 | OK := true 72 | end 73 | end 74 | else 75 | begin 76 | write ('The program will end so that the function '); 77 | writeln ('F can be created. '); 78 | OK := false 79 | end 80 | end; 81 | procedure OUTPUT; 82 | begin 83 | writeln ('Choice of output method: '); 84 | writeln ('1. Output to screen '); 85 | writeln ('2. Output to text file '); 86 | writeln ('Please enter 1 or 2. '); 87 | readln ( FLAG ); 88 | if ( FLAG = 2 ) then 89 | begin 90 | writeln ('Input the file name in the form - drive:name.ext, '); 91 | writeln('for example: A:OUTPUT.DTA'); 92 | readln ( NAME ); 93 | assign ( OUP, NAME ) 94 | end 95 | else assign ( OUP, 'CON' ); 96 | rewrite ( OUP ); 97 | writeln(OUP,'THIS IS THE BACKWARD-DIFFERENCE METHOD'); 98 | writeln(OUP); 99 | write ( OUP,'I':3,'X(I)':12,' W(X(I),',FT:12,')'); 100 | writeln ( OUP ); 101 | for I := 1 to M1 do 102 | begin 103 | X := I * H; 104 | writeln ( OUP, I:3, X:12:8,' ', W[I]:14:8) 105 | end; 106 | close ( OUP ) 107 | end; 108 | begin 109 | INPUT; 110 | if ( OK ) then 111 | begin 112 | M1 := M - 1; 113 | M2 := M - 2; 114 | N1 := N - 1; 115 | { STEP 1 } 116 | H := FX / M; 117 | K := FT / N; 118 | VV := ALPHA * ALPHA * K / ( H * H ); 119 | { STEP 2 } 120 | for I := 1 to M1 do W[I] := F( I * H ); 121 | { STEP 3 122 | STEPS 3 through 11 solve a tridiagonal linear system 123 | using Algorithm 6.7 } 124 | L[1] := 1.0 + 2.0 * VV; 125 | U[1] := -VV / L[1]; 126 | { STEP 4 } 127 | for I := 2 to M2 do 128 | begin 129 | L[I] := 1.0 + 2.0 * VV + VV * U[I-1]; 130 | U[I] := -VV / L[I] 131 | end; 132 | { STEP 5 } 133 | L[M1] := 1.0 + 2.0 * VV + VV * U[M2]; 134 | { STEP 6 } 135 | for J := 1 to N do 136 | begin 137 | { STEP 7 } 138 | { current t(j) } 139 | T := J * K; 140 | Z[1] := W[1] / L[1]; 141 | { STEP 8 } 142 | for I := 2 to M1 do 143 | Z[I] := ( W[I] + VV * Z[I-1] ) / L[I]; 144 | { STEP 9 } 145 | W[M1] := Z[M1]; 146 | { STEP 10 } 147 | for I1 := 1 to M2 do 148 | begin 149 | I := M2 - I1 + 1; 150 | W[I] := Z[I] - U[I] * W[I+1] 151 | end 152 | end; 153 | { STEP 11 } 154 | OUTPUT 155 | end 156 | { STEP 12 } 157 | end. 158 | 159 | 160 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG123.PAS: -------------------------------------------------------------------------------- 1 | 2 | 3 | program ALG123; 4 | { CRANK-NICOLSON ALGORITHM 12.3 5 | 6 | To approximate the solution of the parabolic partial-differential 7 | equation subject to the boundary conditions 8 | u(0,t) = u(l,t) = 0, 0 < t < T = max t 9 | and the initial conditions 10 | u(x,0) = F(x), 0 <= x <= l: 11 | 12 | INPUT: endpoint l; maximum time T; constant ALPHA; integers m, N: 13 | 14 | OUTPUT: approximations W(I,J) to u(x(I),t(J)) for each 15 | I = 1,..., m-1 and J = 1,..., N. 16 | } 17 | var 18 | V,L,U,Z : array [ 1..25 ] of real; 19 | FT,FX,ALPHA,H,K,VV,T,X : real; 20 | N,M,M1,M2,N1,FLAG,I1,I,J : integer; 21 | OK : boolean; 22 | AA : char; 23 | NAME : string [ 30 ]; 24 | OUP : text; 25 | { Change function F for a new problem } 26 | function F( X : real ) : real; 27 | begin 28 | F := sin(pi*X) 29 | end; 30 | procedure INPUT; 31 | begin 32 | writeln('This is the Crank-Nicolson Method.'); 33 | writeln ('Has the function F(x) been created immediately'); 34 | writeln ('preceding the INPUT procedure? Answer Y or N. '); 35 | readln ( AA ); 36 | if ( AA = 'Y' ) or ( AA = 'y' ) then 37 | begin 38 | writeln ('The lefthand endpoint on the X-axis is 0. '); 39 | OK := false; 40 | while ( not OK ) do 41 | begin 42 | writeln ('Input the righthand endpoint on the X-axis. '); 43 | readln ( FX ); 44 | if ( FX <= 0.0 ) then 45 | writeln ('Must be positive number. ') 46 | else 47 | OK := true 48 | end; 49 | OK := false; 50 | while ( not OK ) do 51 | begin 52 | writeln ('Input the maximum value of the time variable T. '); 53 | readln ( FT ); 54 | if ( FT <= 0.0 ) then 55 | writeln ('Must be positive number. ') 56 | else 57 | Ok := true 58 | end; 59 | writeln ('Input the constant alpha. '); 60 | readln ( ALPHA ); 61 | OK := false; 62 | while ( not OK ) do 63 | begin 64 | writeln ('Input integer m = number of intervals on X-axis '); 65 | write ('and N = number of time intervals '); 66 | writeln ('- separated by a blank. '); 67 | writeln('Note that m should be 3 or larger.'); 68 | readln ( M, N ); 69 | if ( ( M <= 2 ) or ( N <= 0 ) ) then 70 | writeln ('Numbers not in the correct range. ') 71 | else 72 | OK := true 73 | end 74 | end 75 | else 76 | begin 77 | write ('The program will end so that the function '); 78 | writeln ('F can be created. '); 79 | OK := false 80 | end 81 | end; 82 | procedure OUTPUT; 83 | begin 84 | writeln ('Choice of output method: '); 85 | writeln ('1. Output to screen '); 86 | writeln ('2. Output to text file '); 87 | writeln ('Please enter 1 or 2. '); 88 | readln ( FLAG ); 89 | if ( FLAG = 2 ) then 90 | begin 91 | writeln ('Input the file name in the form - drive:name.ext, '); 92 | writeln('for example: A:OUTPUT.DTA'); 93 | readln ( NAME ); 94 | assign ( OUP, NAME ) 95 | end 96 | else assign ( OUP, 'CON' ); 97 | rewrite ( OUP ); 98 | writeln(OUP,'CRANK-NICOLSON METHOD'); 99 | writeln(OUP); 100 | write ( OUP,'I':3,'X(I)':12,' W(X(I),',FT:12,')' ); 101 | writeln ( OUP ); 102 | for I := 1 to M1 do 103 | begin 104 | X := I * H; 105 | writeln(OUP,I:3,X:12:8,V[I]:14:8) 106 | end; 107 | close ( OUP ) 108 | end; 109 | begin 110 | INPUT; 111 | if ( OK ) then 112 | begin 113 | M1 := M - 1; 114 | M2 := M - 2; 115 | { STEP 1 } 116 | H := FX / M; 117 | K := FT / N; 118 | { VV is used for lambda } 119 | VV := ALPHA * ALPHA * K / ( H * H ); 120 | { set V(M) = 0 } 121 | V[M] := 0.0; 122 | { STEP 2 } 123 | for I := 1 to M1 do V[I] := F( I * H ); 124 | { STEP 3 125 | STEPS 3 through 11 solve a tridiagonal linear system 126 | using Algorithm 6.7 } 127 | L[1] := 1.0 + VV; 128 | U[1] := -VV / ( 2.0 * L[1] ); 129 | { STEP 4 } 130 | for I := 2 to M2 do 131 | begin 132 | L[I] := 1.0 + VV + VV * U[I-1] / 2.0; 133 | U[I] := -VV / ( 2.0 * L[I] ) 134 | end; 135 | { STEP 5 } 136 | L[M1] := 1.0 + VV + 0.5 * VV * U[M2]; 137 | { STEP 6 } 138 | for J := 1 to N do 139 | begin 140 | { STEP 7 } 141 | { current t(j) } 142 | T := J * K; 143 | Z[1] := ((1.0-VV)*V[1]+VV*V[2]/2.0)/L[1]; 144 | { STEP 8 } 145 | for I := 2 to M1 do 146 | Z[I] := ((1.0-VV)*V[I]+0.5*VV*(V[I+1]+ 147 | V[I-1]+Z[I-1]))/L[I]; 148 | { STEP 9 } 149 | V[M1] := Z[M1]; 150 | { STEP 10 } 151 | for I1 := 1 to M2 do 152 | begin 153 | I := M2 - I1 + 1; 154 | V[I] := Z[I] - U[I] * V[I+1] 155 | end 156 | end; 157 | { STEP 11 } 158 | OUTPUT 159 | end 160 | { STEP 12 } 161 | end. 162 | 163 | 164 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/ALG124.PAS: -------------------------------------------------------------------------------- 1 | program ALG124; 2 | { 3 | WAVE EQUATION FINITE-DIFFERENCE ALGORITHM 12.4 4 | 5 | To approximate the solution to the wave equation: 6 | subject to the boundary conditions 7 | u(0,t) = u(l,t) = 0, 0 < t < T = max t 8 | and the initial conditions 9 | u(x,0) = F(x) and Du(x,0)/Dt = G(x), 0 <= x <= l: 10 | 11 | INPUT: endpoint l; maximum time T; constant ALPHA; integers m, N. 12 | 13 | OUTPUT: approximations W(I,J) to u(x(I),t(J)) for each I = 0, ..., m 14 | and J=0,...,N. 15 | } 16 | var 17 | W : array [ 1..21, 1..21 ] of real; 18 | FT,FX,ALPHA,H,K,V,X : real; 19 | N,M,M1,M2,N1,N2,FLAG,I,J : integer; 20 | OK : boolean; 21 | AA : char; 22 | NAME : string [ 30 ]; 23 | OUP : text; 24 | { Change function F for a new problem } 25 | function F( X : real ) : real; 26 | begin 27 | F := sin( PI * X ) 28 | end; 29 | { Change function G for a new problem } 30 | function G( X : real ) : real; 31 | begin 32 | G := 0.0 33 | end; 34 | procedure INPUT; 35 | begin 36 | writeln('This is the Finite-Difference for the Wave Equation.'); 37 | writeln ('Have the functions F and G been created immediately'); 38 | writeln ('preceding the INPUT procedure? Answer Y or N. '); 39 | readln ( AA ); 40 | if ( AA = 'Y' ) or ( AA = 'y' ) then 41 | begin 42 | writeln ('The lefthand endpoint on the X-axis is 0. '); 43 | OK := false; 44 | while ( not OK ) do 45 | begin 46 | writeln ('Input the righthand endpoint on the X-axis. '); 47 | readln ( FX ); 48 | if ( FX <= 0.0 ) then 49 | writeln ('Must be a positive number. ') 50 | else 51 | OK := true 52 | end; 53 | OK := false; 54 | while ( not OK ) do 55 | begin 56 | writeln ('Input the maximum value of the time variable T. '); 57 | readln ( FT ); 58 | if ( FT <= 0.0 ) then 59 | writeln ('Must be a positive number. ') 60 | else 61 | Ok := true 62 | end; 63 | writeln ('Input the constant ALPHA. '); 64 | readln ( ALPHA ); 65 | OK := false; 66 | while ( not OK ) do 67 | begin 68 | writeln ('Input integer m = number of intervals on X-axis '); 69 | write ('and N = number of time intervals '); 70 | writeln ('- separated by a blank. '); 71 | writeln('Note that m should be 3 or larger.'); 72 | readln ( M, N ); 73 | if ( ( M <= 2 ) or ( N <= 0 ) ) then 74 | writeln ('Numbers not in the correct range. ') 75 | else 76 | OK := true 77 | end 78 | end 79 | else 80 | begin 81 | write ('The program will end so that the functions '); 82 | writeln ('F and G can be created. '); 83 | OK := false 84 | end 85 | end; 86 | procedure OUTPUT; 87 | begin 88 | writeln ('Choice of output method: '); 89 | writeln ('1. Output to screen '); 90 | writeln ('2. Output to text file '); 91 | writeln ('Please enter 1 or 2. '); 92 | readln ( FLAG ); 93 | if ( FLAG = 2 ) then 94 | begin 95 | writeln ('Input the file name in the form - drive:name.ext, '); 96 | writeln ('for example: A:OUTPUT.DTA'); 97 | readln ( NAME ); 98 | assign ( OUP, NAME ) 99 | end 100 | else assign ( OUP, 'CON' ); 101 | rewrite ( OUP ); 102 | writeln(OUP,'FINITE DIFFERENCE METHOD FOR THE WAVE EQUATION'); 103 | writeln(OUP); 104 | write ( OUP,'I':3,'X(I)':12,' W(X(I),',FT:12,')' ); 105 | writeln ( OUP ); 106 | for I := 1 to M1 do 107 | begin 108 | X := ( I - 1.0 ) * H; 109 | writeln(OUP,I:3,X:12:8,W[I,N1]:14:8) 110 | end; 111 | close ( OUP ) 112 | end; 113 | begin 114 | INPUT; 115 | if ( OK ) then 116 | begin 117 | M1 := M + 1; 118 | M2 := M - 1; 119 | N1 := N + 1; 120 | N2 := N - 1; 121 | { STEP 1 122 | V is used for lambda } 123 | H := FX / M; 124 | K := FT / N; 125 | V := ALPHA * K / H; 126 | { STEP 2 127 | the subscripts are shifted to avoid zero subscripts } 128 | for J := 2 to N1 do 129 | begin 130 | W[1,J] := 0.0; 131 | W[M1,J] := 0.0 132 | end; 133 | { STEP 3 } 134 | W[1,1] := F( 0.0 ); 135 | W[M1,1] := F ( FX ); 136 | { STEP 4 } 137 | for I := 2 to M do 138 | begin 139 | W[I,1] := F( H * ( I - 1.0 ) ); 140 | W[I,2] := (1.0-V*V)*F(H*(I-1.0))+V*V*(F(I*H)+ 141 | F(H*(I-2.0)))/2.0+K*G(H*(I-1.0)) 142 | end; 143 | { STEP 5 } 144 | for J := 2 to N do 145 | for I := 2 to M do 146 | W[I,J+1] := 2.0*(1.0-V*V)*W[I,J]+V*V* 147 | (W[I+1,J]+W[I-1,J])-W[I,J-1]; 148 | { STEP 6 } 149 | OUTPUT 150 | end 151 | { STEP 7 } 152 | end. 153 | 154 | 155 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG031.DTA: -------------------------------------------------------------------------------- 1 | 1.0 0.7651977 2 | 1.3 0.6200860 3 | 1.6 0.4554022 4 | 1.9 0.2818186 5 | 2.2 0.1103623 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG032.DTA: -------------------------------------------------------------------------------- 1 | 1.0 0.7651977 2 | 1.3 0.6200860 3 | 1.6 0.4554022 4 | 1.9 0.2818186 5 | 2.2 0.1103623 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG033.DTA: -------------------------------------------------------------------------------- 1 | 1.3 0.6200860 -0.52202320 2 | 1.6 0.4554022 -0.56989590 3 | 1.9 0.2818186 -0.58115710 4 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG034.DTA: -------------------------------------------------------------------------------- 1 | 0.00000000 1.00000000 2 | 0.25000000 1.64872127 3 | 0.50000000 2.71828183 4 | 0.75000000 4.48168907 5 | 1.00000000 7.38905610 6 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG035.DTA: -------------------------------------------------------------------------------- 1 | 0.00000000 1.00000000 2 | 0.25000000 1.64872127 3 | 0.50000000 2.71828183 4 | 0.75000000 4.48168907 5 | 1.00000000 7.38905610 6 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG036.DTA: -------------------------------------------------------------------------------- 1 | 0 0 0.5 0.25 2 | 4 6 3.5 7 4.5 5 3 | 6 1 7 2 4 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG061.DTA: -------------------------------------------------------------------------------- 1 | 1.0 -1.0 2.0 -1.0 -8.0 2 | 2.0 -2.0 3.0 -3.0 -20.0 3 | 1.0 1.0 1.0 0.0 -2.0 4 | 1.0 -1.0 4.0 3.0 4.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG062.DTA: -------------------------------------------------------------------------------- 1 | 1.0 -1.0 2.0 -1.0 -8.0 2 | 2.0 -2.0 3.0 -3.0 -20.0 3 | 1.0 1.0 1.0 0.0 -2.0 4 | 1.0 -1.0 4.0 3.0 4.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG063.DTA: -------------------------------------------------------------------------------- 1 | 1.0 -1.0 2.0 -1.0 -8.0 2 | 2.0 -2.0 3.0 -3.0 -20.0 3 | 1.0 1.0 1.0 0.0 -2.0 4 | 1.0 -1.0 4.0 3.0 4.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG064.DTA: -------------------------------------------------------------------------------- 1 | 6.0 2.0 1.0 -1.0 2 | 2.0 4.0 1.0 0.0 3 | 1.0 1.0 4.0 -1.0 4 | -1.0 0.0 -1.0 3.0 5 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG065.DTA: -------------------------------------------------------------------------------- 1 | 4.0 -1.0 1.0 2 | -1.0 4.25 2.75 3 | 1.0 2.75 3.5 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG066.DTA: -------------------------------------------------------------------------------- 1 | 4.0 -1.0 1.0 2 | -1.0 4.25 2.75 3 | 1.0 2.75 3.5 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG067.DTA: -------------------------------------------------------------------------------- 1 | 2.0 2.0 2.0 2.0 2 | -1.0 -1.0 -1.0 3 | -1.0 -1.0 -1.0 4 | 1.0 0.0 0.0 1.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG071.DTA: -------------------------------------------------------------------------------- 1 | 10.0 -1.0 2.0 0.0 6.0 2 | -1.0 11.0 -1.0 3.0 25.0 3 | 2.0 -1.0 10.0 -1.0 -11.0 4 | 0.0 3.0 -1.0 8.0 15.0 5 | 0.0 0.0 0.0 0.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG072.DTA: -------------------------------------------------------------------------------- 1 | 10.0 -1.0 2.0 0.0 6.0 2 | -1.0 11.0 -1.0 3.0 25.0 3 | 2.0 -1.0 10.0 -1.0 -11.0 4 | 0.0 3.0 -1.0 8.0 15.0 5 | 0.0 0.0 0.0 0.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG073.DTA: -------------------------------------------------------------------------------- 1 | 4 3 0 24 2 | 3 4 -1 30 3 | 0 -1 4 -24 4 | 1 1 1 5 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG074.DTA: -------------------------------------------------------------------------------- 1 | 3.333 15920 -10.333 15913 2 | 2.222 16.71 9.612 28.544 3 | 1.5611 5.1791 1.6852 8.4254 4 |  -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG081.DTA: -------------------------------------------------------------------------------- 1 | 1 -1 0.5 -0.16666666667 0.04166666667 -0.008333333333 0.001388888889 2 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG082.DTA: -------------------------------------------------------------------------------- 1 | 2.532132 -1.130318 0.271495 -0.044337 0.005474 -0.000543 2 | 0 0 0 3 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG083.DTA: -------------------------------------------------------------------------------- 1 | 3.141592 2 | 1.570796 3 | 0 4 | 1.570796 5 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG091.DTA: -------------------------------------------------------------------------------- 1 | -4.0 14.0 0.0 2 | -5.0 13.0 0.0 3 | -1.0 0.0 2.0 4 | 1.0 1.0 1.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG092.DTA: -------------------------------------------------------------------------------- 1 | 4.0 -1.0 1.0 2 | -1.0 3.0 -2.0 3 | 1.0 -2.0 3.0 4 | 1.0 0.0 0.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG093.DTA: -------------------------------------------------------------------------------- 1 | -4.0 14.0 0.0 2 | -5.0 13.0 0.0 3 | -1.0 0.0 2.0 4 | 1.0 1.0 1.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG094.DTA: -------------------------------------------------------------------------------- 1 | -4.0 -1.0 1.0 2 | -1.0 3.0 -2.0 3 | 1.0 -2.0 3.0 4 | 1.0 -1.0 1.0 5 | 6.0 6 | 2.0 1.0 7 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG095.DTA: -------------------------------------------------------------------------------- 1 | 4.0 1.0 -2.0 2.0 2 | 2.0 0.0 1.0 3 | 3.0 -2.0 4 | -1.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG096.DTA: -------------------------------------------------------------------------------- 1 | 3.0 3.0 3.0 1.0 1.0 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG115.DTA: -------------------------------------------------------------------------------- 1 | 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/ALG125.DTA: -------------------------------------------------------------------------------- 1 | 2 6 10 5 11 5 2 | 0.2 0.2 5 3 3 4 1 7 3 8 3 1 1 3 | 0.4 0.2 3 4 3 5 1 2 3 4 | 0.3 0.1 4 4 2 1 3 9 3 2 1 5 | 0.5 0.1 3 5 3 6 1 10 3 6 | 0.6 0.1 1 6 3 7 | 0.0 0.4 1 3 1 8 | 0.0 0.2 2 3 2 7 1 9 | 0.0 0.0 2 7 2 8 1 10 | 0.2 0.0 3 8 2 1 2 9 1 11 | 0.4 0.0 4 5 2 9 2 2 2 10 1 12 | 0.6 0.0 2 6 2 10 2 13 | 1 6 2 1 4 2 5 4 11 5 -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/dta/alg075.dta: -------------------------------------------------------------------------------- 1 | 4 3 0 24 2 | 3 4 -1 30 3 | 0 -1 4 -24 4 | 0.5 0 0 5 | 0 0.5 0 6 | 0 0 0.5 7 | 0 0 0 8 | -------------------------------------------------------------------------------- /minipascal/tests-numerical/pascal/readme_p.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/soegaard/minipascal/646c1cedefc3d269db43b9d186d892655d4efb78/minipascal/tests-numerical/pascal/readme_p.pdf -------------------------------------------------------------------------------- /minipascal/tests-numerical/readme.md: -------------------------------------------------------------------------------- 1 | Numerical Analysis 2 | ================== 3 | The programs in the folder "pascal" 4 | is from the book 5 | 6 | Numerical Analysis, 9th ed. 7 | Burden & Faires 8 | 9 | See 10 | http://www.math.ysu.edu/~faires/Numerical-Analysis/Programs/ 11 | -------------------------------------------------------------------------------- /minipascal/tests-real/primes.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal 2 | {(* Eratosthenes Sieve Prime Number Program in PASCAL *)} 3 | program primes; 4 | 5 | {This is the original version from Byte, with only the modifications necessary 6 | to allow it to compile under UCSD and a bell at the end. 7 | If you choose to report your results, 8 | PLEASE RUN IT AS IS! It is a known fact that the speed of this version 9 | can be significantly improved by turning off range checking and re-ordering 10 | the declarations of the variables, but this is the version which has been used 11 | most and we desire consistantcy. 12 | 13 | Start timing by typing and stop at the bell. gws} 14 | 15 | {The results of this version on several systems have been reported on MUSUS. 16 | 17 | System UCSD version Time (sec) 18 | ------ ------------ ---------- 19 | 20 | Sage II IV.1 57 (68000 at 8 MHz) 21 | WD uEngine III.0 59 (fillchar is so slow on uE) 22 | 23 | LSI-11/23 IV.01 92-122 (depends on memory speed) 24 | LSI-11/23 II.0 105 (98 seconds under IV.01) 25 | LSI-11/23 IV.1 107 (non-extended memory) 26 | LSI-11/23 IV.1 128 (extended memory) 27 | 28 | NEC APC IV.1 144 8086 at 4.9 Mhz extended memory 29 | 30 | JONOS IV.03 ? 162 (pretty good for a 4 MHz Z-80A) 31 | NorthStar I.5 183 (Z-80 at 4 MHz) 32 | OSI C8P-DF II.0 ? 197 (6502 at 2 MHz) 33 | H-89 II.0 200 (4 MHz Z-80A) 34 | LSI-11/2 IV.0 202 35 | IBM PC IV.03 203 (4.77 MHz 8088) 36 | LSI-11/2 II.0 220 37 | 38 | Apple ][ II.1 390 (1 MHz 6502) 39 | H-89 II.0 455 (2 MHz Z-80) 40 | 41 | } 42 | 43 | {Feb. 2013 44 | Minimal changes to run in MiniPacal: 45 | - added fillchar routine 46 | - lowercased 47 | /soegaard 48 | 49 | http://archive.org/stream/byte-magazine-1981-09/ 50 | BYTE_Vol_06-09_1981-09_Artifical_Intelligence_djvu.txt 51 | } 52 | 53 | const 54 | size = 8190; 55 | type 56 | flagarray = array [0..size] of boolean; 57 | 58 | var 59 | flags : flagarray; 60 | i,prime,k,count,iter : integer; 61 | 62 | procedure fillchar(fs:flagarray; n:integer; c:char); 63 | var 64 | i:integer; 65 | begin 66 | for i:=0 to n do 67 | fs[i]:=c; 68 | end; 69 | 70 | begin 71 | for iter := 1 to 10 do 72 | begin 73 | count := 0; 74 | fillchar(flags,high(flags),chr(1)); 75 | for i := 0 to size do 76 | if flags[i] then 77 | begin 78 | prime := i+i+3; 79 | k := i + prime; 80 | while k <= size do 81 | begin 82 | flags[k] := false; 83 | k := k + prime 84 | end; 85 | count := count + 1; 86 | end; 87 | end; 88 | write(count, ' primes'); 89 | end. 90 | -------------------------------------------------------------------------------- /minipascal/tests-real/stackoverflow-primes.rkt: -------------------------------------------------------------------------------- 1 | #lang minipascal simple 2 | {http://stackoverflow.com/questions/14673601/ 3 | how-to-write-numbers-separated-with-commas-in-a-loop-on-one-line } 4 | program prime; 5 | var 6 | P:integer; 7 | I:integer; 8 | J:integer; 9 | A:integer; 10 | 11 | function mod(x,y:integer):integer; 12 | begin 13 | mod:= x- (x div y)*y; 14 | end; 15 | 16 | begin 17 | writeln('Prime number program'); 18 | writeln; 19 | writeln('Insert number'); 20 | read(P); 21 | 22 | for I:=2 to P-1 do 23 | begin 24 | J:=Mod(P, I); 25 | if (J=0) then 26 | begin 27 | writeln(P,' divides with ',I); 28 | a:=a+1 29 | end; 30 | end; 31 | 32 | if a=0 then 33 | begin 34 | writeln(P,' is prime number'); 35 | end; 36 | end. --------------------------------------------------------------------------------