diff --git a/MIGRATION_PLAN.md b/MIGRATION_PLAN.md new file mode 100644 index 0000000..7da11be --- /dev/null +++ b/MIGRATION_PLAN.md @@ -0,0 +1,260 @@ +# Python 3 Migration Plan + +## Scope + +The original system is a cooperative composition pipeline built from three neural subsystems: + +- `Bach`: a Hopfield-Tank note generator over a 5-position by 8-note grid. +- `Salieri`: a back-propagation critic trained against a rule-based classical-sequence supervisor. +- `Beethoven`: an ART1 novelty/category network over the note sequence plus one classicality bit. + +The immediate goal should be a Python 3 package that reproduces the Pascal algorithms and file-driven behavior closely enough to validate compatibility, while replacing the Pascal linked-list memory model with direct numeric data structures. + +## What Exists Today + +### Core orchestration + +- `THES/ANNCOMP.PP` is the integrated driver. +- The composition loop is effectively: + 1. Generate a candidate note with the Hopfield-Tank network. + 2. Evaluate/train the back-propagation network using the current note window and the rule-based instructor. + 3. Pass the same window plus the classical/not-classical flag into ART1. + +### Shared state + +- `THES/GLOBALS.PP` defines: + - fixed note vocabulary of 8 notes, + - sequence window length of 5, + - ART1 dimensions `Max_F1_nodes = 41`, `Max_F2_nodes = 25`, + - `Common_Area_`, which is the cross-network exchange object. + +### Hopfield-Tank subsystem + +- `THES/ANNCOMP.PP` implements `Bach` and nested `HTN`. +- The network operates on a flattened 40-cell representation: `8 notes x 5 positions`. +- It loads a `64 x 64` weight matrix from `HTN.DAT`, but the active note grid uses the first 40 cells. +- The update rule uses: + - per-neuron activation `a`, + - output `0.5 * (1 + tanh(a / c))`, + - resistance/capacitance/input/weight/iteration scaling factors from globals. +- `THES/HTNDATA.PP` shows how the Hopfield weights were built from `SEQUENCE.DAT`, plus row/column inhibition and sequence reinforcement. + +### Back-propagation subsystem + +- `THES/BP_UNIT.PP` is a general BP implementation with: + - input, hidden, and output nodes, + - weight matrix and momentum, + - feed-forward, + - back-propagation, + - file-based parameter and weight loading. +- `THES/S61.DAT` configures Salieri as: + - 40 input nodes, + - 20 hidden nodes, + - 1 output node, + - learning rate `0.5`, + - momentum `0.5`. +- `THES/ANNCOMP.PP` converts the current 5-note window into a 40-bit one-hot vector and trains the network online against `Classical_instructor`. + +### Rule-based supervisor + +- `THES/CLASINST.PP` loads `SEQUENCE.DAT`. +- It converts the 5-note sequence to a digit string and returns `1` if the target suffix matches any stored example sequence, else `0`. +- This acts as the teaching signal for the BP network. + +### ART1 subsystem + +- `THES/ANNCOMP.PP` implements `ART1`. +- F1 input is the 40-bit one-hot sequence plus one bit for `Is_classical`, for a total vector length of 41. +- F2 supports up to 25 committed categories. +- The implementation includes a nonstandard compatibility detail: when all categories are saturated and none remain eligible, vigilance is reduced by 1 percent and matching is retried. + +### Legacy data model problem + +- `THES/STRUCT.PP` provides generic linked-list vectors and matrices (`DVE`, `HVE`) used to work around Turbo Pascal memory constraints. +- `THES/BP_UNIT.PP` stores nodes, IO vectors, and weights through those linked structures rather than direct arrays. +- That representation should not be preserved in Python except where needed for compatibility tests. + +## Recommended Python Representation + +Use explicit typed structures and dense arrays: + +- `numpy.ndarray` for: + - Hopfield state vectors and weight matrices, + - BP activations, deltas, biases, and weights, + - ART1 F1/F2 activations and top-down/bottom-up LTM weights. +- `dataclasses.dataclass` for stable API/state containers. +- `Enum` for note identifiers only if it does not complicate file compatibility. + +Recommended canonical encodings: + +- `NoteSequence`: shape `(5,)`, integer values `0..8`. +- `SequenceOneHot`: shape `(40,)`, binary. +- `ArtInputVector`: shape `(41,)`, binary. +- `HopfieldWeights`: shape `(40, 40)` as the normalized active subset of the legacy file. +- `BPWeightsIH`, `BPWeightsHO` or one legacy-compatible dense square matrix, depending on whether fidelity or clarity is prioritized in a given layer of the codebase. + +## Package Layout + +```text +composer_ans/ + __init__.py + types.py + encoding.py + io/ + __init__.py + legacy_files.py + hopfield.py + backprop.py + art1.py + classical_rules.py + pipeline.py + compatibility.py +tests/ + data/ + test_encoding.py + test_classical_rules.py + test_hopfield.py + test_backprop.py + test_art1.py + test_pipeline.py +``` + +## API Design + +Keep the public API small and deterministic. + +```python +from composer_ans.pipeline import CompositionContext, CompositionPipeline + +ctx = CompositionContext(notes=[0, 0, 0, 0, 0]) +pipeline = CompositionPipeline.from_legacy_data("THES") +result = pipeline.step(ctx) +``` + +Suggested subsystem APIs: + +```python +candidate = hopfield.generate_next_note(notes, params) +is_classical, bp_state = salieri.evaluate_and_train(notes, target=None) +art_result = beethoven.categorize(notes, is_classical) +``` + +Where: + +- `target=None` means "derive target from the classical instructor", matching the Pascal integrated flow. +- Each call returns structured state useful for debugging and test baselines, not just the final scalar. + +## Migration Strategy + +### Phase 1: Preserve semantics, not implementation style + +- Recreate file readers for: + - `SEQUENCE.DAT`, + - `S61.DAT`, + - `S61.WT`, + - `HTN.DAT`. +- Recreate sequence encodings exactly: + - 5-note rolling window, + - 40-bit one-hot flattening, + - ART1 extra classicality bit. +- Recreate the rule-based instructor exactly before porting the trainable models. + +Deliverable: + +- A Python package that can parse legacy files and reproduce the same encoded inputs the Pascal code would produce. + +### Phase 2: Port Hopfield-Tank + +- Implement the continuous-time iterative update as written. +- Preserve: + - noise injection behavior, + - stop condition using epsilon on alternating time buffers, + - "pick max cell in each column" post-processing. +- Isolate random number generation behind an injectable RNG so deterministic tests are possible. + +Deliverable: + +- `generate_next_note()` producing the same result as Pascal for fixed seeds and known sequences. + +### Phase 3: Port Salieri back-propagation + +- First implement a legacy-compatible execution mode mirroring the square-node storage and update order. +- Then wrap it with a clearer façade that exposes standard layer matrices. +- Preserve: + - sigmoid behavior, + - theta updates, + - momentum handling, + - online training after every presentation, + - periodic weight dumping capability. + +Deliverable: + +- `evaluate_and_train()` matching legacy outputs and weight updates for a controlled presentation sequence. + +### Phase 4: Port Beethoven ART1 + +- Port the F1/F2 STM and LTM equations directly. +- Preserve: + - 41-bit input vector, + - eligibility and commitment logic, + - resonance loop, + - modified vigilance-reduction behavior on saturation. +- Keep ART1 state persistent across calls, because the Pascal version learns over the composition session. + +Deliverable: + +- `categorize()` returning winner, new-category flag, vigilance-change flag, and current category count. + +### Phase 5: Rebuild the integrated pipeline + +- Recreate `Common_Area_` as a Python dataclass. +- Implement a single-step pipeline equivalent to one iteration of the Pascal composition loop. +- Add an optional batch runner that emits a complete composition and an event log. + +Deliverable: + +- End-to-end run over a fixed number of notes using legacy data assets. + +## Compatibility Plan + +Compatibility should be measured in layers: + +- Encoding compatibility: + - identical one-hot vectors and ART input vectors for the same note windows. +- File compatibility: + - legacy `.DAT` and `.WT` files load without manual editing. +- Behavioral compatibility: + - same classical instructor decisions, + - same Hopfield winner for fixed seed/input, + - same BP output progression for replayed presentations, + - same ART1 category decisions for replayed inputs. +- Pipeline compatibility: + - same sequence of generated notes for a fixed random seed, or if exact replication is blocked by legacy RNG differences, same per-step subsystem outputs within defined tolerances. + +## Known Risks + +- Pascal `Single`, file layout, and RNG behavior may not map exactly to Python defaults. +- `HTN.DAT` is written as a Pascal binary `FILE OF ARRAY[1..64,1..64] OF REAL`; a dedicated reader may be needed to confirm element size and ordering. +- The BP code relies on update order within linked structures. A mathematically equivalent refactor may still diverge numerically unless a legacy mode preserves operation order. +- ART1 has thesis-specific modifications; replacing them with textbook ART1 would break compatibility. + +## Recommended Delivery Order + +1. Build legacy readers and encoders. +2. Port `Classical_instructor`. +3. Port Hopfield-Tank and verify with controlled seeds. +4. Port BP in legacy-compatible mode and replay known presentations. +5. Port ART1 with persistent state. +6. Assemble the integrated pipeline. +7. Add a second, cleaner API layer only after compatibility tests pass. + +## Immediate Next Step + +Implement the non-neural compatibility layer first: + +- legacy file parsers, +- note/sequence encoders, +- rule-based classical instructor, +- golden tests based on the files already in `THES`. + +That gives a stable foundation for porting the three neural subsystems without losing track of what the original program actually did. diff --git a/README.md b/README.md index bfdf820..7b6c982 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,100 @@ # TriuneCadence -A Python3 port of the music composition code from my 1989 master's thesis, 'Integration and Hybridization in Neural Network Modelling'. \ No newline at end of file +TriuneCadence is a Python implementation of a modular neural music-composition system inspired by Wesley R. Elsberry's 1989 master's thesis on constrained melodic composition. + +It combines three different network families in one pipeline: + +- a Hopfield-Tank note generator +- a back-propagation critic (`Salieri`) +- an ART1 novelty/category module (`Beethoven`) + +The repository includes: + +- a modern Python codebase with generic network modules and thesis-specific adapters +- legacy thesis source, text, and data files in [`THES/`](./THES) +- timing, entropy, and predictability analysis for generated note sequences +- JSON serialization for learned model state and run reports + +## Why This Repo Exists + +The original system was implemented in Turbo Pascal on late-1980s hardware under severe memory constraints. That led to pointer-heavy data structures and implementation complexity that obscured what was, architecturally, a strong multi-network design. + +This repository keeps the core ideas accessible: + +- generic reusable implementations of the underlying network families +- a thesis-faithful composition pipeline built on top of those generic modules +- a practical environment for experimentation, analysis, and historical comparison + +## Quick Start + +Run a short composition from the thesis data: + +```bash +python -m composer_ans --thes-root THES --notes 16 +``` + +Or, if installed as a package: + +```bash +triune-cadence --thes-root THES --notes 16 +``` + +Save model state and a run report: + +```bash +triune-cadence \ + --thes-root THES \ + --notes 32 \ + --save-salieri salieri.json \ + --save-beethoven beethoven.json \ + --save-report run.json +``` + +## Sweepable Parameters + +The CLI currently exposes a few parameters that are useful for experiments: + +- `--object-threshold` +- `--max-attempts-per-note` +- `--art-vigilance` +- `--art-vigilance-decay` + +Saved run reports include those parameters along with: + +- note sequence +- per-note generation time +- total runtime +- unigram entropy +- first-order conditional entropy +- normalized entropy +- predictability +- redundancy + +## Project Layout + +Core Python modules live in [`composer_ans/`](./composer_ans): + +- generic Hopfield-Tank core: [`composer_ans/hopfield.py`](./composer_ans/hopfield.py) +- generic back-propagation core: [`composer_ans/backprop.py`](./composer_ans/backprop.py) +- generic ART1 core: [`composer_ans/art1.py`](./composer_ans/art1.py) +- thesis-specific wrappers: [`composer_ans/salieri.py`](./composer_ans/salieri.py), [`composer_ans/beethoven.py`](./composer_ans/beethoven.py) +- integrated composition pipeline: [`composer_ans/pipeline.py`](./composer_ans/pipeline.py) +- analysis and reporting: [`composer_ans/analysis.py`](./composer_ans/analysis.py), [`composer_ans/reporting.py`](./composer_ans/reporting.py) + +Legacy materials are in [`THES/`](./THES). + +## Historical Context + +The thesis reports that the integrated system generated 152 notes in about three hours on a 16 MHz 80386-class machine, and in about fifteen hours on an 8088-based machine with an 8087 coprocessor. This Python version can report per-note generation time directly so present-day runs can be compared against those historical figures. + +## Development + +Run the test suite with: + +```bash +pytest -q +``` + +## Related Repo Notes + +The original migration planning artifact is preserved in [`MIGRATION_PLAN.md`](./MIGRATION_PLAN.md). diff --git a/THES/ANN.PP b/THES/ANN.PP new file mode 100644 index 0000000..2c6d2c1 --- /dev/null +++ b/THES/ANN.PP @@ -0,0 +1,193 @@ + + +UNIT ANN; +{ +This unit provides several functions of general use in Artificial Neural +Network (ANN) modelling. +} + +{ + +Copyright 1989 by Wesley R. Elsberry. All rights reserved. + +Commercial use of this software is prohibited without written consent of +the author. + +For information, bug reports, and updates contact + +Wesley R. Elsberry +528 Chambers Creek Drive South +Everman, Texas 76140 +Telephone: (817) 551-7018 + +} + +INTERFACE + +{PUBLIC DECLARATIONS} +FUNCTION Close_enough (target, plus_minus, x : DOUBLE) : BOOLEAN; +FUNCTION Gaussian_noise (mean, variance : DOUBLE) :DOUBLE; +FUNCTION Tanh (rr : DOUBLE) :DOUBLE ; +FUNCTION Linear (m, B, X : DOUBLE):DOUBLE; +FUNCTION Linear_ramp (low, high, x : DOUBLE) : DOUBLE; +FUNCTION Threshold (low, high, thresh, x : DOUBLE):DOUBLE; +FUNCTION Sigmoid (range,slope_mod,shift,X : DOUBLE):DOUBLE; +FUNCTION Signum (xx : DOUBLE):INTEGER; + +IMPLEMENTATION + +{PRIVATE DECLARATIONS} + + CONST + mach_inf = 1E37; + exp_max = 80.0; + + TYPE + REAL = DOUBLE; + + +{IMPLEMENTATIONS OF PROCEDURES AND FUNCTIONS} + + FUNCTION Close_enough (target, plus_minus, x : REAL) : BOOLEAN; +{ + Given a target and an absolute value of allowed deviation (plus_minus), + Close_enough returns TRUE if the tested value (x) is within the + defined interval. +} + + BEGIN {} + IF (x >= (target - plus_minus)) AND (x <= (target + plus_minus)) + THEN {} + BEGIN + Close_enough := TRUE; + END + ELSE {} + BEGIN + Close_enough := FALSE; + END; + END; {} + + FUNCTION Gaussian_noise(mean, variance : REAL) :REAL; +{Produces random numbers which conform to a Gaussian distribution} + + VAR + u1, u2, x : REAL; + + BEGIN {Gaussian_noise} + u1 := Random; + u2 := Random; + x := Sqrt(-2*Ln(u1))*Cos(2*Pi*u2); + x := variance*x + mean; + Gaussian_noise := x; + END; {Gaussian_noise} + + +{ + Activation functions +} + + FUNCTION tanh(rr : REAL) :REAL ; +{returns the hyperbolic tangent of rr} + + BEGIN {tanh} + IF (rr > Exp_Max) THEN {} + BEGIN + rr := Exp_Max; + END; + IF (rr < -Exp_Max) THEN {} + BEGIN + rr := -Exp_max; + END; + tanh := (Exp(rr) - Exp(-rr)) / (Exp(rr) + Exp(-rr)); + END; + + + FUNCTION Linear (m, B, X : REAL):REAL; +{ + Linear returns the parameter value times slope, plus intercept. +} + + BEGIN {Linear} + Linear := X*m + B; + END; {Linear} + + FUNCTION Linear_ramp (LOW, HIGH, X : REAL) : REAL; +{ + Returns X when X is between LOW and HIGH, the appropriate bound + otherwise. +} + + BEGIN {Linear_ramp} + IF (X < HIGH) AND (X > LOW) THEN + {} + BEGIN + Linear_ramp := X; + END + ELSE {} + BEGIN + IF (x >= HIGH) THEN {} + BEGIN + Linear_ramp := HIGH; + END + ELSE {} + BEGIN + Linear_ramp := LOW; + END; + END; + END; {Linear_ramp} + + FUNCTION Threshold(LOW,HIGH,THRESH,X : REAL):REAL; +{ + Returns LOW when X is below THRESH and HIGH when X is greater + than or equal to THRESH. +} + + BEGIN {Threshold} + IF (X < THRESH) THEN {} + BEGIN + Threshold := LOW; + END + ELSE {} + BEGIN + Threshold := HIGH; + END; + END; {Threshold} + + FUNCTION Sigmoid(range,slope_mod,shift,X : REAL):REAL; +{ + Function of the form : + + [ range / (1 + exp(-slope_mod * X)) ] - shift + + range - determines the range of values, 0..range + slope_mod - modifies the slope of the curve + shift - changes the range from 0..range to (0-shift)..(range-shift) +} + + CONST + Machine_Infinity = 1E37; + + VAR + Temp : REAL; + + BEGIN {Sigmoid} + Temp := 0.0 - (Slope_mod * X); + IF Temp > Exp_Max THEN Temp := Exp_Max; + IF Temp < -Exp_Max THEN Temp := -Exp_Max; + Temp := Exp(Temp); + Sigmoid := (range/(1+(Temp))) - shift; + END; {Sigmoid} + + FUNCTION signum(xx : REAL):INTEGER; + + BEGIN + IF xx >= 0.0 THEN signum := 1 + ELSE signum := -1; + END; + + +BEGIN {INITIALIZATION} +END. + + + \ No newline at end of file diff --git a/THES/ANNCOMP.PP b/THES/ANNCOMP.PP new file mode 100644 index 0000000..8614549 --- /dev/null +++ b/THES/ANNCOMP.PP @@ -0,0 +1,1742 @@ + +PROGRAM Note_Generator (INPUT,OUTPUT); +{ +This program demonstrates a small application which uses three +major neural network models to advantage in a cooperative, +integrated manner. The problem is that of generating musical +notes in a well-formed, but not repetitious manner. The scale of +notes is limited, and only one note is generated per time interval. +} + +{ + +Copyright 1989 by Wesley R. Elsberry. All rights reserved. + +Commercial use of this software is prohibited without written consent of +the author. + +For information, bug reports, and updates contact + +Wesley R. Elsberry +528 Chambers Creek Drive South +Everman, Texas 76140 +Telephone: (817) 551-7018 + +} + + +USES + DOS, {Turbo Pascal MS-DOS functions} + CRT, {Turbo Pascal IBM-PC screen and keyboard functions} + ANN, {Artificial Neural Network functions} + Struct, {Linked-list structure functions} + Misc1, {Miscellaneous functions} + ANSI_Z, {ANSI screen control functions} + BP_unit, {Back-propagation network functions} + Globals, {Global types and constants} + ClasInst; {Classical Instructor function} + +VAR + inf : TEXT; {Input file handle} + outf : TEXT; {Output file handle} + main_ii, {Loop variable} + main_jj : INTEGER; {Loop variable} + main_done : BOOLEAN; {Loop variable} + main_time : Time_rec_; {Record for time info} + Time1, Time2 : Time_rec_; + Testr : REAL; + Inchar : char; + note_rec : note_record_; + ii : INTEGER; + snet : BP_net_; + + {For Beethoven (ART 1)} + F1 : F1_layer_ptr_; + F2 : F2_layer_ptr_; + {End VAR declarations} + +{---------------------------------------------------------} + +PROCEDURE Wait; +{} +BEGIN {} +{ Writeln('Press a key...');} +{ READ(inchar);} +END; {} + +{----------------------------------------------------------} + + + +PROCEDURE report_notes (VAR cmn : Common_area_); + + TYPE + outstr_ = STRING[10]; + + VAR + ii : INTEGER; + raoutf : FILE OF CHAR; + raoutfname : STRING; + och : CHAR; + + BEGIN + {open note file} + {skip to end} + {write note} + {close} + + raoutfname := FSEARCH('BEETHOVN.MUS',GETENV('PATH')); + IF raoutfname <> '' THEN BEGIN + Assign(raoutf,raoutfname); + Reset(raoutf); + END + ELSE BEGIN + Assign(raoutf,'BEETHOVN.MUS'); + Rewrite(raoutf); + END; + Seek (raoutf, FileSize(raoutf)); + {go to end of file} + IF note_rec.c = 2 THEN BEGIN + och := ascii_cr; + Write(raoutf,och); + och := ascii_lf; + Write(raoutf,och); + och := ascii_asterisk; + Write(raoutf,och); + och := ascii_equal; + Write(raoutf,och); + och := ascii_asterisk; + Write(raoutf,och); + och := ascii_cr; + Write(raoutf,och); + och := ascii_lf; + Write(raoutf,och); + END; + och := Chr(note_rec.n[note_rec.c-1]+48); + Write(raoutf,och); + och := ascii_cr; + Write(raoutf,och); + och := ascii_lf; + Write(raoutf,och); + IF note_rec.c = 153 THEN BEGIN + och := ascii_cr; + Write(raoutf,och); + och := ascii_lf; + Write(raoutf,och); + och := ascii_asterisk; + Write(raoutf,och); + och := ascii_equal; + Write(raoutf,och); + och := ascii_asterisk; + Write(raoutf,och); + och := ascii_cr; + Write(raoutf,och); + och := ascii_lf; + Write(raoutf,och); + END; + Close(raoutf); + ANSI_CUP(2,0); + Write('Notes generated: '); + ANSI_CUP(2,25); + Write((note_rec.c-1):3); + END; + + + PROCEDURE record_a_note (VAR cmn : Common_area_); + + CONST + Init : BOOLEAN = FALSE; + c : INTEGER = 1; + + TYPE + outstr_ = STRING[10]; + + VAR + ii : INTEGER; + raoutf : FILE OF CHAR; + raoutfname : STRING; + och : CHAR; + + BEGIN + IF NOT init THEN BEGIN + FillChar(note_rec.n,SizeOf(note_rec.n),#0); + note_rec.c := 1; + Init := TRUE; + END; + FOR ii := 1 TO V_len_out-1 DO BEGIN + {} + cmn.notes[ii] := cmn.notes[ii+1]; + END; {} + cmn.notes[V_len_out] := 0; + note_rec.n[note_rec.c] := cmn.notes[v_len_out-1]; + INC(note_rec.c); + report_notes(cmn); + END; + + + PROCEDURE play_a_note(VAR cn : BYTE); + + BEGIN + CASE cn OF + 1 : Sound(n_c_mid); + 2 : Sound(n_d); + 3 : Sound(n_e); + 4 : Sound(n_f); + 5 : Sound(n_g); + 6 : Sound(n_a); + 7 : Sound(n_b); + 8 : Sound(n_c_hi); + ELSE + NoSound; + END; + Delay(180); + NoSound; + Delay(55); + END; + + + PROCEDURE play_notes (nr : note_record_); + + VAR + ii : INTEGER; + + BEGIN + ii := 1; + FOR ii := 1 TO nr.c DO play_a_note ( nr.n[ii]); + END; + + + + PROCEDURE {Change_global_factors} + user_keys; + + CONST + Initialized : BOOLEAN = FALSE; + + VAR + inch : CHAR; + instr : STRING; + tempr : REAL; + err : INTEGER; + + PROCEDURE display_global_factors; + + BEGIN + ANSI_CUP(13,12); + Write('*res: ',HTN_co_res:5:4); + ANSI_CUP(14,12); + Write('*cap: ',HTN_co_cap:5:4); + ANSI_CUP(15,12); + Write(' *wt: ',HTN_co_wt:5:4); + ANSI_CUP(16,12); + Write('*inp: ',HTN_co_inp:5:4); + ANSI_CUP(17,12); + Write('epsi: ',epsilon:5:4); + ANSI_CUP(18,12); + Write('iter: ',HTN_co_iter:5:4); + ANSI_CUP(9,55); + Write('*Vigilance: ',ART_co_vigilance:5:4); + ANSI_CUP(23,0); + END; + + + BEGIN + IF NOT Initialized THEN BEGIN + ANSI_CUP(23,0); + Write + ('Type "C" to change factors, "P" to play notes so far.'); + display_global_factors; + ANSI_CUP(23,0); + Initialized := TRUE; + END; {IF NOT Initialized} + + IF check_kbd_status THEN BEGIN + IF dir_console_IO(inch) THEN BEGIN + inch := UpCase(inch); + IF inch = 'C' THEN BEGIN + ANSI_CUP(21,0); + Write( + 'Change: 1)epsi 2)*res 3)*cap 4)*wt 5)*inp 6)iter 7)*vigilance' + ); + REPEAT + WHILE (NOT dir_console_IO(inch)) DO ; + UNTIL (inch IN ['1','2','3','4','5','6','7']); + REPEAT + ANSI_CUP(21,0); + ANSI_EEOL; + ANSI_CUP(21,0); + Write('Input value: '); + Readln(instr); + Val(instr,tempr,ii); + UNTIL (ii = 0); + CASE inch OF + '1' : epsilon := tempr; + '2' : HTN_co_res := tempr; + '3' : HTN_co_cap := tempr; + '4' : HTN_co_wt := tempr; + '5' : HTN_co_inp := tempr; + '6' : HTN_co_iter := tempr; + '7' : ART_co_vigilance := tempr; + END; + ANSI_CUP(22,0); + ANSI_EEOL; + display_global_factors; + ANSI_CUP(23,0); + END + ELSE IF inch = 'P' THEN BEGIN + play_notes(note_rec); + END; {Else if inch} + END; + END; + END; + +{----------------------------------------------------------} + + PROCEDURE Bach(VAR cmn : Common_Area_); +{Generates a new note from past sequence and frequency information. + Uses a Hopfield-Tank network to accomplish this task. } +{INPUTS: + Sequence of notes, 4 notes long + OUTPUT: + Single note, valued from 1 to 8 + } + +{Hopfield-Tank network. Given data and input values, + processes for output.} + + PROCEDURE HTN(VAR cma : Common_Area_); + + CONST + Initialized : BOOLEAN = FALSE; + + TYPE + W_A_ptr_ = ^Weight_Array_; + weight_array_ = ARRAY[1..64,1..64] OF REAL; + file_string_ = STRING[127]; + neuron_ = RECORD + a : REAL; {activation value} + r : REAL; {resistance} + c : REAL; {capacitance} + o : REAL; {output} + i : REAL; {input} + END; + neuron_array_ = ARRAY[1..v_len_in,1..v_len_out] OF neuron_; + note_array_ = ARRAY[1..5] OF INTEGER; + + CONST + WA : W_A_ptr_ = NIL; + + VAR + inf : FILE OF weight_array_; + Time_step : INTEGER; + ns : ARRAY[0..1] OF neuron_array_; + ii, jj, kk : INTEGER; + nbase, nindex : INTEGER; + + FUNCTION Neuron_Output(act,cap :REAL):REAL; + + BEGIN + neuron_output := 0.5 *(1 + tanh(act/cap)); + END; + + FUNCTION max_cell_in_column(col : INTEGER):INTEGER; + + VAR + ii, jj : INTEGER; + Hi : REAL; + nsptr : INTEGER; + + BEGIN {max_cell_in_column} + Hi := 0.0; + nsptr := time_step MOD 2; + FOR ii := 1 TO v_len_in DO BEGIN + IF (ns[nsptr,ii,col].o > Hi) THEN BEGIN + Hi := ns[nsptr,ii,col].o; + jj := ii; + END; + END; + max_cell_in_column := jj; + END; {max_cell_in_column} + + FUNCTION done(epsi : REAL):BOOLEAN; + + VAR + finish : BOOLEAN; + ii, jj : INTEGER; + t : REAL; + + BEGIN + finish := FALSE; + ii := 1; + WHILE (NOT finish) AND (ii <= V_len_in) DO BEGIN + FOR jj := 1 TO 5 DO BEGIN + IF ABS(ns[0,ii,jj].o - ns[1,ii,jj].o) > epsi THEN + finish := TRUE; + END; + ii := ii + 1; + END; + done := NOT finish; + END; + + FUNCTION Convert_to_weight_coord(note,posit : INTEGER):INTEGER; + + BEGIN {Convert_to_weight_coord} + Convert_to_weight_coord := (v_len_in*(posit-1)+note); + END; {Convert_to_weight_coord} + + + FUNCTION delta_neuron_activation(a,r,i : REAL; + note,posit : INTEGER):REAL; + + VAR + ii, jj : INTEGER; + tempr1, tempr2 : REAL; + sum : REAL; + di1,di2 : INTEGER; + current : INTEGER; + + BEGIN {delta_neuron_activation} + current := time_step MOD 2; + sum := 0.0; + di1 := Convert_to_weight_coord(note,posit); + FOR ii := 1 TO v_len_in DO + FOR jj := 1 TO v_len_out DO BEGIN + di2 := Convert_to_weight_coord(ii,jj); + sum := sum + + (WA^[di1,di2] * HTN_co_wt) + * ns[current,ii,jj].o; + END; + delta_neuron_activation := + (-(ns[current,note,posit].a + / (ns[current,note,posit].r * HTN_co_res)) + + (ns[current,note,posit].i * HTN_co_inp) + sum) + / (ns[current,note,posit].c * HTN_co_cap); + END; {delta_neuron_activation} + + + FUNCTION iterate_htn(VAR nts : notes_):INTEGER; + + VAR + II, JJ, next_time : INTEGER; + + PROCEDURE display_neuron_activation; + + CONST + column = 0; + row = 10; + + VAR + ii, jj : INTEGER; + ts : INTEGER; + active : INTEGER; + + BEGIN {display_neuron_activation} + ts := time_step; + FOR ii := 1 TO v_len_in DO BEGIN + {FOR ii} + ANSI_CUP(row+ii,0); + FOR jj := 1 TO v_len_out DO BEGIN + {FOR jj} + active := Round(ns[ts,ii,jj].o * 10); + IF active > 10 THEN active := 10; + IF active < 1 THEN active := 1; + Write(Copy(graphic_string,active,1),' '); + END; {FOR jj} + END; {FOR ii} + ANSI_CUP(23,0); + END; {display_neuron_activation} + + PROCEDURE update_neuron_output; + + VAR + ii, jj : INTEGER; + + BEGIN + FOR ii := 1 TO v_len_in DO BEGIN + {FOR ii} + FOR jj := 1 TO v_len_out DO BEGIN + {FOR jj} + ns[time_step,ii,jj].o := + neuron_output(ns[time_step,ii,jj].a, + ns[time_step,ii,jj].c); + END; {FOR jj} + END; {FOR ii} + END; + + + BEGIN {iterate_HTn} + + time_step := 0; + {initialize the neuron arrays} + FOR ii := 1 TO 8 DO + FOR jj := 1 TO 5 DO BEGIN + ns[0,ii,jj].a := 0.5; + ns[0,ii,jj].o := 0.0; + ns[1,ii,jj].o := 0.0; + IF (nts[jj] = 0) THEN BEGIN + {randomize input} + ns[0,ii,jj].i := gaussian_noise(0.5,0.25); + ns[1,ii,jj].i := ns[0,ii,jj].i; + END + ELSE BEGIN + IF (nts[jj] = ii) THEN BEGIN + ns[0,ii,jj].i := 0.67 + + gaussian_noise(0.0,0.1); + ns[1,ii,jj].i := ns[0,ii,jj].i; + END + ELSE BEGIN + ns[0,ii,jj].i := 0.33 + + gaussian_noise(0.0,0.1); + ns[1,ii,jj].i := ns[0,ii,jj].i; + END; + END; + END; + {prevent premature end} + ns[1,1,1].o := 20; + update_neuron_output; + + WHILE (NOT done(epsilon)) DO BEGIN + user_keys; + time_step := time_step MOD 2; + next_time := (time_step + 1) MOD 2; + {determine output term for neurons} + update_neuron_output; + FOR ii := 1 TO v_len_in DO BEGIN + {FOR ii} + FOR jj := 1 TO v_len_out DO BEGIN + {FOR jj} + ns[next_time,ii,jj].a := ns[time_step,ii,jj].a + + HTN_co_iter + * delta_neuron_activation(ns[time_step, + ii,jj].a, ns[time_step,ii,jj].r, + ns[time_step,ii,jj].i,ii,jj); + END; {FOR jj} + END; {FOR ii} + display_neuron_activation; + time_step := time_step + 1; + END; {WHILE} + +{**Change of note: Finding the highest activity in each column and +setting it for further processing will change the behavior of the +net and program. The change is being made to improve performance of +the ART1 network.**} + FOR ii := 1 TO v_len_out DO BEGIN + nts[ii] := max_cell_in_column(ii); + END; + + iterate_htn := nts[v_len_out]; + END; {Iterate_HTn} + + BEGIN {HTn} + { Initialized := False;} + IF (NOT Initialized) THEN{do initialize} + BEGIN {get weight matrix} + New(WA); + Assign(inf,'htn.dat'); + Reset(inf); + Read(inf,WA^); + Close(inf); + Initialized := TRUE; + ANSI_CUP(8,0); + Write('HTN:'); + ANSI_CUP(9,0); + Write('Node activity'); + ANSI_CUP(11,12); + Write('R: ',global_resistance:5:3); + ANSI_CUP(12,12); + Write('C: ',global_capacitance:5:3); + ANSI_CUP(23,0); + END; + FOR ii := 1 TO 8 DO + FOR jj := 1 TO 5 DO BEGIN + ns[0,ii,jj].r := global_resistance; + ns[0,ii,jj].c := global_capacitance; + ns[1,ii,jj].r := global_resistance; + ns[1,ii,jj].c := global_capacitance; + END; + + FOR ii := 1 TO v_len_out DO + {clear notes} + cma.notes[ii] := 0; + + nbase := note_rec.c - v_len_out; + FOR nindex := 1 TO (v_len_out - 1) DO BEGIN + IF ((nbase + nindex) > 0) THEN + cma.notes[nindex] := note_rec.n[(nbase+nindex)]; + END; {For} + + cma.Candidate_note := iterate_htn(cma.notes); + cma.notes[v_len_out] := cma.candidate_note; + + END; {HTn} + + BEGIN {Bach} + Dump_Common(cmn); + HTn(cmn); + END; {Bach} + + +{----------------------------------------------------------} + + PROCEDURE Salieri(VAR cmn : Common_Area_); + {Compares past information and proposed note generated by Bach with + rules of classical composition. A PDP network is used to do this.} + + PROCEDURE Back_propagation(VAR cmn : Common_Area_); + {A PDP style back propagation network.} + + CONST + Initialized : BOOLEAN = FALSE; + count : WORD = 1; + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, jj, kk : INTEGER; + Done : BOOLEAN; + tp1 : DVE_ptr_; + error_m, tne, sum : ARRAY[1..3] OF REAL; + ss : STRING; + binsum : ARRAY[1..3] OF INTEGER; + + FUNCTION max (r1, r2 :REAL):REAL; + + BEGIN + IF r1 >= r2 THEN max := r1 + ELSE max := r2; + END; + + PROCEDURE Set_input_vector_from_notes (vp : DVE_ptr_; + n : notes_); + + VAR + ii : INTEGER; + vpt : DVE_ptr_; + vn : ARRAY[1..40] OF INTEGER; + + BEGIN + + FillChar (vn,SizeOf(vn),#0); + {Blank the current vector} + FOR ii := 1 TO 5 DO BEGIN + {Notes subscript} + IF n[ii] > 0 THEN vn [((ii-1)*8)+n[ii]] := 1; + END; {For notes subscript} + + vpt := vp; + FOR ii := 1 TO snet.n_input DO BEGIN + vnp_(vpt^.dptr)^.v := vn[ii]; + vpt := vpt^.right; + END; {FOR ii} + END; + + BEGIN + IF NOT Initialized THEN BEGIN + snet.data_fname := 's61.dat'; + + ANSI_CUP(15,40); + + Setup_BP_net (snet,snet.data_fname); + Write(snet.data_fname); + + ANSI_CUP(16,40); + Set_BP_net_weights_from_file(snet,snet.wt_fname); + + Write(snet.wt_fname); + Initialized := TRUE; + END; + + {now set up current input vector} + Set_input_vector_from_notes(snet.vi,cmn.notes); + + {get the supervisor's critique for the current sequence} + vnp_(snet.vts^.dptr)^.v := Classical_instructor (cmn.notes); + + {Feed-forward, back-propagate, and make changes} + BP_train_and_change (snet); + + {determine response of the net to the current sequence} + cmn.Is_classical := (vnp_(snet.vos^.dptr)^.v > 0.50); + + {keep weight changes that have been made now and then} + IF (count MOD 49) = 0 THEN + Dump_BP_net_weights(snet,snet.wt_fname); + + INC(count); + END; + + BEGIN {Salieri} + Dump_common(cmn); + Back_propagation(cmn); + END; {Salieri} + + +{----------------------------------------------------------} + + PROCEDURE Beethoven(VAR cmn : Common_Area_); + {} + + PROCEDURE ART1(VAR cma : Common_Area_); + {Binary Adaptive Resonance Theory model} + { + Carpenter and Grossberg's ART1 paradigm + + Copyright 1988, W.R. Elsberry & D.J. Blackwood + Written in Turbo Pascal 5.5, September 1988 + +} +{ + Terminology: + + STM = Short Term Memory + LTM = Long Term Memory + TD = Top-down + BU = Bottom-up + + F1 layer = a vector of nodes which receive input from three sources: + External input, a binary vector + Gain control, an internal processing input + F2 layer, activation of category nodes through LTM traces + + F2 layer = a set of nodes which have LTM memory traces associated + with them that relate to the BU activations to particular nodes in + the F2 level. + Inputs: F1 activation through BU LTM traces, Gain Control, + System Reset + +} + + +{ + Parameter constraints from Carpenter & Grossberg, 1987 + + A >= 0 + mu1, mu2 >= 0 (Simpson) + + C >= 0 + epsilon1, epsilon2 >= 0 (Simpson) + + MAX(1,D) < B < 1 + D + MAX(1,gamma1) < sigma1 < (1 + gamma1) (Simpson) + + 0 < e << 1 + + K = O(1) + + L > 1 + + 0 < p <= 1 + 0 < Vigilance <= 1 (Simpson) + + 0 < Z_IJ(0) < (L / (L-1+M)) + 0 < Wup(0) < (L / (L - 1 + Max_F1_nodes)) (Simpson) + + 1 >= Z_JI(0) > Z_BAR == ((B-1)/D) + 1 >= Wdn(0) > ? == ((sigma2-1)/gamma2) (Simpson) + + 0 <= I,f,g,h <= 1 + +} + + CONST + Initialized : BOOLEAN = FALSE; + Initial_Wup = 0.1; + Initial_Wdn = 0.9; + Number_committed_F2 : INTEGER = 0; + Vigilance : REAL = 0.9; {Determines what level of mismatch will + cause reset} + Time_slice : REAL = 0.1; {Factor to multiply deltas by} + + {The following are part of the F1 STM recall equation} + mu1 : REAL = 1; {Positive constant controlling BU input & TD + feedback} + sigma1 : REAL = 1.4; {Positive constant regulating gain control} + epsilon1 : REAL = 1; {Positive constant regulating gain control} + gamma1 : REAL = 1; {Positive constant regulating TD and BU + feedback} + + {The following are part of the F2 STM recall equation} + mu2 : REAL = 1; {Positive constant controlling BU input & TD + feedback} + sigma2 : REAL = 1.4; {Positive constant regulating gain control} + epsilon2 : REAL = 1; {Positive constant regulating gain control} + gamma2 : REAL = 1; {Positive constant regulating BU input} + + + {The following are part of the Bottom-Up LTM equation} + alpha1 : REAL = 1; {Positive constant for learning rate} + beta1 : REAL = 1; {Positive constant for passive decay} + + {The following are part of the Top-Down LTM equation} + alpha2 : REAL = 1; {Positive constant for learning rate} + beta2 : REAL = 1; {Positive constant for passive decay} + + VAR + i, j : INTEGER; + F2_winner : INTEGER; {Index of winning F2 node} + + Input_on : BOOLEAN; {Is input currently being received?} + Resonance : BOOLEAN; + + {The following are part of the match operation equation} + Vector_I : Vector_; {Binary input vector} + Vector_X : Vector_; {Binary expected vector} + + PROCEDURE Build_Expected_Vector; +{} + + CONST + low = 0.0; + high = 1.0; + {thresh = 0.5;} + + VAR + ii, jj : INTEGER; + thresh : REAL; + + BEGIN {Build_Expected_Vector} + thresh := 0.0; + + WITH F2^[F2_winner] DO BEGIN + {with} + FOR ii := 1 TO Max_F1_nodes DO BEGIN + {} + thresh := thresh + Wdn[ii]; + END; {} + thresh := thresh / Vector_length; + + FOR ii := 1 TO Max_F1_nodes DO BEGIN + Vector_X[ii] := BYTE(Round (Threshold(low, high, thresh, + Wdn[ii]) )); + END; + END; {with} + END; {Build_Expected_Vector} + + + PROCEDURE Build_Input_Vector; +{} + + VAR + ii, jj : INTEGER; + + FUNCTION One_if_NZ(This, That : INTEGER) :INTEGER; +{} + + VAR + ii : INTEGER; + + BEGIN {} + ii := This AND That; + IF (ii <> 0) THEN {} + BEGIN + ii := 1; + END; + One_if_NZ := ii; + END; {} + + BEGIN {Build_Input_Vector} + FillChar (vector_i,SizeOf(vector_i),#0); + {Blank the current vector} + FOR ii := 1 TO 5 DO BEGIN + {Notes subscript} + IF cma.notes[ii] > 0 THEN + vector_i [((ii-1)*8)+cma.notes[ii]] := 1; + END; {For notes subscript} + + IF (cma.Is_classical) THEN + {} + BEGIN + Vector_I[Max_F1_nodes] := 1; + END + ELSE {} + BEGIN + Vector_I[Max_F1_nodes] := 0; + END; + END; {Build_Input_Vector} + + + PROCEDURE Display_vectors; +{} + + VAR + vii : INTEGER; + + BEGIN {} + ANSI_CUP(8,28); + Write('ART1: # Committed F2: ',Number_committed_F2, + ' Vigilance: ',vigilance:5:4); + ANSI_CUP(9,37); + Write('F2 Winner : ',F2_winner:3); + + ANSI_CUP(10,28); + Write('Expected Vector vs. Input Vector'); + ANSI_CUP(12,28); + Write('IV: '); + FOR vii := 1 TO vector_length DO BEGIN + {} + IF ((vii MOD 8) = 1) AND (vii <> 1) THEN Write(' '); + Write(Vector_I[vii]); + END; {} + ANSI_CUP(11,28); + Build_Expected_Vector; + Write('EV: '); + FOR vii := 1 TO vector_length DO BEGIN + {} + IF ((vii MOD 8) = 1) AND (vii <> 1) THEN Write(' '); + Write(Vector_X[vii]); + END; {} + END; {} + + PROCEDURE Clear_ART1; +{} + + VAR + ii, jj : INTEGER; + + BEGIN {Clear_ART1} + FOR ii := 1 TO Max_F2_nodes DO BEGIN + {Clear F2 node parameters} + WITH F2^[ii] DO BEGIN + Eligible := TRUE; + Curr_B := 0; + Last_B := 0; + END; + END; {Clear F2 node parameters} + FOR ii := 1 TO Max_F1_nodes DO BEGIN + {Clear F1 node parameters} + WITH F1^[ii] DO BEGIN + Curr_A := 0; + Last_A := 0; + END; + END; {Clear F1 node parameters} + F2_winner := 0; + END; {Clear_ART1} + + PROCEDURE Initialize_ART1; +{} + + VAR + ii, jj, kk : INTEGER; + + BEGIN {Initialize_ART1} + Number_committed_F2 := 0; + New(F2); + New(F1); + FOR kk := 1 TO Max_F2_nodes DO BEGIN + {FOR} + WITH F2^[kk] DO BEGIN + {WITH} + Committed := FALSE; + FOR ii := 1 TO Vector_Length DO BEGIN + {For} + Wup[ii] := Initial_Wup; + Wdn[ii] := Initial_Wdn; + Last_B := 0.0; + Curr_B := 0.0; + END; {For} + END; {WITH} + END; {FOR} + FOR kk := 1 TO Max_F1_nodes DO BEGIN + {} + WITH F1^[kk] DO BEGIN + {} + Last_A := 0.0; + Curr_A := 0.0; + END; {} + END; {} + END; {Initialize_ART1} + + + FUNCTION Delta_STM_F1_node(nde : INTEGER):REAL; +{ + Simpson (1988) Eq. 19 + + a_dot[nde] = - a[nde] + + (1 - mu1 * a[nde]) * + (gamma1 * F2[f2_winner].wdn[nde] + Input[nde]) + - (sigma1 + epsilon1 * a(nde) * (1 if there is a winner) + (0 otherwise) + + t1 = - a[nde] + t2 = + (1 - mu1 * a[nde]) + t3 = (gamma1 * F2[f2_winner].wdn[nde] + Input[nde]) + + t4 = (sigma1 + epsilon1 * a(nde) + t5 = (1 if there is a winner) + (0 otherwise) + so, + + Delta_STM_F1_node := t1 + t2*t3 - t4*t5; + +} + + VAR + ii, jj : INTEGER; + t1, t2, t3, t4, t5 : REAL; + + BEGIN {Delta_STM_F1_node} + t1 := 0; + t2 := 0; + t3 := 0; + t4 := 0; + t5 := 0; + + WITH F1^[nde] DO BEGIN + t1 := - Last_A; + t2 := (1 - mu1*Last_A); + IF (F2_winner <> 0) THEN + {} + BEGIN {Make TD term} + t3 := F2^[F2_winner].Wdn[nde]; + END; + t3 := (gamma1*t3 + Vector_I[nde]); + t4 := (sigma1 + epsilon1*Last_A); + IF (F2_winner > 0) THEN + {} + BEGIN + t5 := 1; + END + ELSE {} + BEGIN + t5 := 0; + END; + END; + Delta_STM_F1_node := t1 + t2*t3 - t4*t5; + END; {Delta_STM_F1_node} + + + FUNCTION Delta_STM_F2_node(nde : INTEGER):REAL; +{ + Simpson (1988) Eq. 20 + + b_dot[nde] = - b[nde] + + (1 - mu2 * b[nde])b* + (gamma2 * [sum over i of S(a[i] * F2[i].wup[nde] ] + + f(b[nde]) + - (sigma2 + epsilon2 * b(nde) * + [sum over k<>j of S(b[k]) ] + where, + t1 = - b[nde] + t2 = (1 - mu2 * b[nde]) + t3 = (gamma2 * [sum over i of S(a[i] * F2[i].wup[nde] ] + f(b[nde]) + t4 = (sigma2 + epsilon2 * b(nde) + t5 = [sum over k<>j of S(b[k]) ] + + Delta_STM_F2_node := t1 + t2*t3 - t4*t5; +} + + CONST + range = 1; + slope_mod = 1; + shift = 0; + + VAR + ii, jj : INTEGER; + t1, t2, t3, t4, t5 : REAL; + + BEGIN {Delta_STM_F2_node} + + t1 := 0; + t2 := 0; + t3 := 0; + t4 := 0; + t5 := 0; + + WITH F2^[nde] DO BEGIN + t1 := - Last_B; + t2 := (1 - mu2*Last_B); + + FOR ii := 1 TO Max_F1_nodes DO BEGIN + {Make TD term} + t3 := t3 + sigmoid(1,1,0,F1^[ii].Curr_A)*Wup[ii]; + END; {Make TD term} + IF (nde = F2_winner) THEN{} + BEGIN + jj := 1; + END + ELSE {} + BEGIN + jj := 0; + END; + + t3 := (gamma2*t3 + jj); + t4 := (sigma2 + epsilon2*Last_B); + FOR ii := 1 TO number_Committed_F2 DO BEGIN + {for} + IF (Eligible) THEN BEGIN + IF (ii <> nde) THEN + t5 := t5 + Sigmoid(range, slope_mod, shift, + F2^[ii].Last_B); + END; + END; {for} + END; + Delta_STM_F2_node := t1 + t2*t3 - t4*t5; + END; {Delta_STM_F2_node} + + FUNCTION Delta_LTM_Bottom_Up(F2_nde, F1_nde : INTEGER):REAL; +{ + Simpson (1988) Eq. 16 + + wup_dot(ij) = alpha1 * f(b[j]) * (-beta1 * wup[ij] + S(a[i]) ) + + This corrects an error in the text! +} + + CONST + range = 1; + slope_mod = 1; + shift = 0; + + VAR + ii, jj : INTEGER; + t1, t2, t3,t4, t5 : REAL; + + BEGIN {Delta_LTM_Bottom_Up} + IF (F2_winner = F2_nde) THEN{} + BEGIN + WITH F2^[F2_nde] DO BEGIN{} + Delta_LTM_Bottom_Up := alpha1 * ( -beta1 * Wup[F1_nde] + + Sigmoid (range, slope_mod, shift, + F1^[F1_nde].curr_A) ); + END; + END + ELSE BEGIN + Delta_LTM_Bottom_Up := 0; + END; + END; {Delta_LTM_Bottom_Up} + + FUNCTION Delta_LTM_Top_Down(F2_nde, F1_nde : INTEGER):REAL; +{ + Simpson (1988) Eq. 17 + + wdn_dot(ji) = alpha2 * f(b[j]) * (-beta2 * wdn[ji] + S(a[i]) ) + + This also corrects an error in the text! +} + + CONST + range = 1; + slope_mod = 1; + shift = 0; + + VAR + ii, jj : INTEGER; + t1, t2, t3,t4, t5 : REAL; + + BEGIN {Delta_LTM_Top_Down} + IF (F2_winner = F2_nde) THEN{} + BEGIN + WITH F2^[F2_nde] DO BEGIN{} + Delta_LTM_Top_Down := + alpha2 * ( -beta2 * Wdn[F1_nde] + Sigmoid( + range, slope_mod, shift, F1^[F1_nde].curr_A) ); + END; {} + END + ELSE BEGIN + Delta_LTM_Top_Down := 0; + END; + END; {Delta_LTM_Top_Down} + + FUNCTION Raw_match:INTEGER; +{ + Result of bitwise AND of Vector_I and Vector_X +} + + VAR + ii, jj : INTEGER; + + BEGIN {Raw_match} + jj := 0; + FOR ii := 1 TO Vector_length DO BEGIN + {} + IF (Vector_I[ii] = 1) AND (Vector_X[ii] = 1) THEN + {} + BEGIN + jj := jj + 1; + END + ELSE {} + BEGIN + END; + END; {} + Raw_match := jj; + END; {Raw_match} + + FUNCTION Ones_in_Vector_I:REAL; +{} + + VAR + ii, jj : INTEGER; + + BEGIN {Ones_in_Vector_I} + jj := 0; + FOR ii := 1 TO Vector_Length DO BEGIN + {} + jj := jj + Vector_I[ii]; + END; {} + Ones_in_Vector_I := jj; + END; {Ones_in_Vector_I} + + FUNCTION Match:BOOLEAN; +{ + Return TRUE if Match between I and X exceeds vigilance +} + + VAR + RM, OVI : REAL; + + BEGIN {Match} + RM := Raw_Match; + OVI := Ones_in_Vector_I; + IF (OVI = 0) THEN {} + BEGIN + IF (RM > 0) THEN {} + BEGIN + Match := TRUE; + END + ELSE {} + BEGIN + Match := FALSE; + END; + END + ELSE {} + BEGIN + Match := ((RM/OVI) >= (Vigilance * ART_co_vigilance)); + END; + END; {Match} + + FUNCTION Saturated:BOOLEAN; +{} + + BEGIN {Saturated} + Saturated := (Number_committed_F2 >= Max_F2_nodes); + END; {Saturated} + + + FUNCTION Find_F2_winner : INTEGER; +{} + + VAR + ii, jj : INTEGER; + max_value : REAL; + Max_position : INTEGER; + Min_num : INTEGER; + + BEGIN {Find_F2_winner} + {Find the maximum activation} + max_value := -1.0E38; + MAX_POSITION := 1; + IF (Number_Committed_F2 < Max_F2_nodes) THEN + {} + BEGIN + Min_num := Number_Committed_F2; + END + ELSE {} + BEGIN + Min_num := Max_F2_nodes; + END; + + FOR jj := 1 TO Min_Num DO BEGIN + {FOR} + WITH F2^[jj] DO BEGIN {WITH} + IF (Eligible) AND (Committed) THEN BEGIN + {Eligible AND Committed} + IF (Curr_B > max_value) THEN BEGIN + {Current > Max} + max_value := Curr_B; + max_position := jj; + END; {Current > Max} + END; {Eligible AND Committed} + END; {WITH} + END; {FOR} + IF (Number_committed_F2 > 0) THEN + {} + BEGIN + Find_F2_winner := max_position; + ANSI_CUP(8,28); + Write + ('ART1: # Committed F2: ',Number_committed_F2, + ' Vigilance: ',vigilance:5:4); + ANSI_CUP(9,37); + Write('F2 Winner : ',max_position:3); + ANSI_CUP(23,0); + wait; + END + ELSE {} + BEGIN + Find_F2_winner := 0; + ANSI_CUP(9,37); + Write('F2 Winner : ',0:3); + ANSI_CUP(23,0); + END; + END; {Find_F2_winner} + + FUNCTION Changed_STM_F1(epsilon : REAL) : BOOLEAN; +{} + + VAR + ii, jj : INTEGER; + Temp : BOOLEAN; + rr : REAL; + + BEGIN {Changed_STM_F1} + Temp := FALSE; + FOR II := 1 TO Vector_Length DO BEGIN + {For} + WITH F1^[ii] DO BEGIN {With} + rr := ABS(Curr_A - Last_A); + IF (rr > epsilon) THEN{Changed} + BEGIN + Temp := TRUE; + END; + END; {With} + END; {For} + Changed_STM_F1 := Temp; + END; {Changed_STM_F1} + + FUNCTION Changed_STM_F2 (epsilon : REAL): BOOLEAN; +{} + + VAR + ii, jj : INTEGER; + Temp : BOOLEAN; + rr : REAL; + + BEGIN {Changed_STM_F2} + Temp := FALSE; + IF (F2_winner > 0) AND (F2_winner <= Max_F2_nodes) THEN BEGIN + WITH F2^[F2_winner] DO BEGIN + {With} + rr := ABS(Curr_B - Last_B); + IF (rr > epsilon) THEN{Changed} + BEGIN + Temp := TRUE; + END; + END; {With} + END + ELSE BEGIN + Temp := FALSE; + END; + + Changed_STM_F2 := Temp; + END; {Changed_STM_F2} + + PROCEDURE Do_resonate; +{} + + CONST + Iter = 10; + E = 0.05; + + VAR + ii, jj, End_loop : INTEGER; + + BEGIN {Do_resonate} + End_loop := 0; + + {While change in STM do alternate BU and TD STM and BU and TD LTM} + REPEAT {} + {BU STM} + FOR ii := 1 TO Vector_Length DO BEGIN + {For F1 STM} + WITH F1^[ii] DO BEGIN {With F1} + Last_A := Curr_A; + Curr_A := Last_A + time_slice * Delta_STM_F1_node(ii); + END; {With F1} + END; {For F1 STM} + + {BU LTM} + FOR ii := 1 TO Vector_Length DO BEGIN + {For BU LTM} + WITH F2^[F2_winner] DO BEGIN + {With F2_winner} + Wup[ii] := Wup[ii] + time_slice + * Delta_LTM_Bottom_up(F2_winner,ii); + END; {With F2_winner} + END; {For BU LTM} +{ Display_vectors;} + + {TD STM} + WITH F2^[F2_winner] DO BEGIN + {} + Last_B := Curr_B; + Curr_B := Last_B + time_slice + * Delta_STM_F2_node(F2_winner); + END; {} + + {TD LTM} + + FOR ii := 1 TO Vector_Length DO BEGIN + {For TD LTM} + WITH F2^[F2_winner] DO BEGIN + {With F2_winner} + Wdn[ii] := Wdn[ii] + time_slice + * Delta_LTM_Top_Down(F2_winner,ii); + END; {With F2_winner} + END; {For TD LTM} +{ Display_vectors;} + End_Loop := End_Loop + 1; + UNTIL ((NOT Changed_STM_F1(e)) AND (NOT Changed_STM_F2(e))) + OR (End_loop > Iter); {} + Display_vectors; + Resonance := TRUE; + + END; {Do_resonate} + + + FUNCTION Exists_eligible : BOOLEAN; +{} + + VAR + ii, jj : INTEGER; + Temp : BOOLEAN; + + BEGIN {Exists_eligible} + Temp := FALSE; + FOR jj := 1 TO Number_committed_F2 DO BEGIN + {FOR} + WITH F2^[jj] DO BEGIN {WITH} + IF (Eligible) AND (Committed) THEN BEGIN + {Eligible AND Committed} + Temp := TRUE; + END; {Eligible AND Committed} + END; {WITH} + END; {FOR} + Exists_eligible := Temp; + END; {Exists_eligible} + + PROCEDURE Encode_New_F2; +{} + + VAR + ii, jj : INTEGER; + + BEGIN {} + IF number_committed_F2 < Max_F2_nodes THEN BEGIN + {Find next uncommitted F2 node} + F2_winner := Number_committed_F2 + 1; + {Resonate uncommitted F2 node with F1} + Do_resonate; + F2^[F2_winner].Eligible := TRUE; + F2^[F2_winner].Committed := TRUE; + Number_committed_F2 := Number_committed_F2 + 1; + END; {IF } + END; {} + + + PROCEDURE Find_F1_activation; + + VAR + i, j : INTEGER; + + BEGIN + ANSI_CUP(14,37); + Write('Find F1 Activation':30); + ANSI_CUP(23,0); + FOR j := 1 TO 3 DO + FOR i := 1 TO Vector_Length DO BEGIN + {FOR} + WITH F1^[i] DO BEGIN {WITH} + Last_A := Curr_A; + Curr_A := Last_A + time_slice * Delta_STM_F1_Node(i); + END; {WITH} + END; {FOR} + END; + + PROCEDURE Find_F2_activation; + + VAR + i, J : INTEGER; + + BEGIN + ANSI_CUP(14,37); + Write('Find F2 Activation':30); + ANSI_CUP(23,0); + FOR j := 1 TO Number_committed_F2 DO BEGIN + {FOR} + WITH F2^[j] DO BEGIN {WITH} + IF (Eligible) AND (Committed) THEN + {} + BEGIN + Last_B := Curr_B; + Curr_B := Last_B + time_slice * Delta_STM_F2_node(j); + END; + END; {WITH} + END; {FOR} + END; + + + + BEGIN {ART1} + ANSI_CUP(8,28); + Write('ART1:'); + ANSI_CUP(14,28); + Write('Process:'); + ANSI_CUP(23,0); + Build_Input_vector; + IF (NOT Initialized) THEN BEGIN {do initialize} + ANSI_CUP(14,37); + Write('Initialize':30); + ANSI_CUP(23,0); + Initialize_ART1; + Initialized := TRUE; + END; + + {Clear_ART} + ANSI_CUP(14,37); + Write('Clear':30); + ANSI_CUP(23,0); + Clear_ART1; + + cma.Delta_Vigilance := FALSE; + cma.New_Category := FALSE; + + REPEAT + user_keys; + Resonance := FALSE; + {Find current F1 activation} + {F1_i node activation * Wij} + Find_F1_activation; + {Send F1 activation to F2} + Find_F2_activation; + {If no committed F2 nodes, then + proceed to new encoding} + IF (NOT exists_eligible) OR (number_committed_F2 = 0) THEN + {} + BEGIN + ANSI_CUP(14,37); + Write('No comm. F2, encoding':30); + ANSI_CUP(23,0); + Encode_New_F2; + Resonance := TRUE; + cma.New_Category := TRUE; + END + ELSE BEGIN + {F2 competition} + {Determine maximum of + eligible F2 nodes} + ANSI_CUP(14,37); + Write('F2 Competition':30); + ANSI_CUP(23,0); + F2_winner := Find_F2_winner; + {F2 winner sends TD image back to F1} + {Activation of F2 winner * Wji} + Display_vectors; {Makes a call to Build_Expected_Vector} + {Compare Input vector to F2 TD vector} + IF (Match) THEN BEGIN {Resonate} + ANSI_CUP(14,37); + Write('Matched, now resonate':30); + ANSI_CUP(23,0); + + Resonance := TRUE; + Do_resonate; + END {Resonate} + ELSE BEGIN {Mismatch} + ANSI_CUP(14,37); + Write('Mismatch':30); + ANSI_CUP(23,0); + {Make the F2 node ineligible} + F2^[F2_winner].Eligible := FALSE; + {Have we saturated?} + {Yes, lower vigilance and restart} + { * While this is not part of the + Carpenter-Grossberg ART 1 architecture, + this modification we felt necessary for + the small number of category nodes which + we are using in the model. * } + + IF (Saturated) AND (NOT exists_eligible) THEN + {If saturation reached decrease vigilance and + restart} + BEGIN {Saturation} + ANSI_CUP(14,37); + Write('Saturated, vigilance--':30); + ANSI_CUP(23,0); {vigilance is decreased} + Vigilance := Vigilance * 0.99; + ANSI_CUP(8,57); + Write('Vigilance: ',vigilance:5:4); + ANSI_CUP(23,0); + cma.Delta_Vigilance := TRUE; + {call clear_ART1} + Clear_ART1; + Find_F1_activation; + Find_F2_activation;{now find closest match and resonate} + F2_winner := Find_F2_winner; + + Resonance := TRUE; + Do_resonate; + END {Saturation} + ELSE BEGIN {Not saturated or exists_eligible} + {Are there eligible F2 nodes?} + IF (Exists_eligible) THEN + {Yes, go on with current process} + BEGIN + ANSI_CUP(14,37); + Write('Search Eligible F2':30); + ANSI_CUP(23,0); {Just continue} + END + ELSE BEGIN + {No, form a new encoding if not saturated} + IF NOT saturated THEN BEGIN + ANSI_CUP(14,37); + Write('Encode new category':30); + ANSI_CUP(23,0); + Encode_New_F2; + Resonance := TRUE; + cma.New_Category := TRUE; + END; {IF NOT saturated} + END; + END; {Not saturated} + END; {Mismatch} + END; {ELSE} + UNTIL (Resonance); + {Prep info to pass back} + END; {ART1} + +{----------------------------------------------------} + BEGIN {Beethoven} + Dump_common(cmn); + ART1(cmn); + END; {Beethoven} + + + + +{----------------------------------------------------------} + + + PROCEDURE Lobes; +{ + Keeps track of played notes, maintaining sequence information. + Uses data from Beethoven to determine when to override Salieri. +} + + CONST + Max_notes_in_composition = 152; + Object_threshold = 3; + Frustration_threshold = 10; + + VAR + Common : Common_Area_; + Number_notes : INTEGER; {Note counter} + Objects : BOOLEAN; + Note_Played : BOOLEAN; + Generate_Candidate : BOOLEAN; + Need_Critique : BOOLEAN; + Need_Compose : BOOLEAN; + Since_Novelty, Frustration : INTEGER; + ii : INTEGER; + + BEGIN {Lobes} + Randomize; + note_rec.c := 0; + Since_Novelty := 0; + Frustration := 0; + Common.notes[1] := 0; + Common.notes[2] := 0; + Common.notes[3] := 0; + Common.notes[4] := 0; + Common.notes[5] := 0; + Common.delta_vigilance := FALSE; + Common.new_category := FALSE; + Common.candidate_note := 0; + Common.is_classical := FALSE; + + ANSI_CUP(14,37); + Write('Begin Simulation':30); + ANSI_CUP(23,0); + + FOR Number_notes := 1 TO Max_notes_in_composition DO BEGIN + {} + user_keys; + + Note_played := FALSE; + Generate_Candidate := TRUE; + Need_Critique := TRUE; + Need_Compose := TRUE; + + REPEAT + IF Generate_candidate THEN + {Generate a candidate note, HTn} + BEGIN + Bach(Common); + ANSI_CUP(6,0); + Write('Candidate Note:'); + ANSI_CUP(6,35); + Write(common.candidate_note); + ANSI_CUP(23,0); + END; + wait; + IF Need_Critique THEN BEGIN + {Find if it is a candidate sequence, PDP} + Salieri(Common); + ANSI_CUP(5,0); + Write('Candidate sequence classical?:'); + ANSI_CUP(5,31); + Write(common.Is_Classical); + ANSI_CUP(23,0); + END; + wait; + IF Need_Compose THEN {Pass through ART and } + BEGIN + Beethoven(Common); + END; + wait; {IF Delta_vigilance or New_category, + then zero the count} + {Else increment the count} + IF (Common.Delta_vigilance OR Common.New_Category) THEN + {} + BEGIN + Since_Novelty := 0; + END + ELSE {} + BEGIN + Since_novelty := Since_Novelty + 1; + END; + IF (Common.Delta_vigilance) THEN BEGIN + INC(Frustration); + END; + + {If count >= Object_threshold), then Objects + is true, reset count} + {Else Objects is false} + Objects := (Since_Novelty >= Object_threshold); + {OR (Frustration > Frustration_Threshold);} + IF Objects THEN since_novelty := 0; + IF (objects AND common.is_classical) OR ((NOT objects) + AND (NOT common.is_classical)) THEN BEGIN + generate_candidate := TRUE; + need_critique := TRUE; + need_compose := TRUE; + common.notes[v_len_out] := 0; + INC(Frustration); + END + ELSE BEGIN + record_a_note(Common); + note_played := TRUE; + Frustration := 0; + END; + UNTIL (Note_played); {A note has been played} + + END; {} + + END; {Lobes} + + + + +{----------------------------------------------------------} + +BEGIN {Main} + + WRITELN('Copyright 1989 by Wesley R. Elsberry'); + DELAY(2000); + ANSI_CLRSCR; + + Lobes; + +END. {Main} + + \ No newline at end of file diff --git a/THES/ANSI_Z.PP b/THES/ANSI_Z.PP new file mode 100644 index 0000000..f1a985c --- /dev/null +++ b/THES/ANSI_Z.PP @@ -0,0 +1,377 @@ +UNIT ANSI_Z; +{ +This unit provides certain ANSI and VT-52 screen control functions. +} +{ + +Copyright 1989 by Wesley R. Elsberry. All rights reserved. + +Commercial use of this software is prohibited without written consent of +the author. + +For information, bug reports, and updates contact + +Wesley R. Elsberry +528 Chambers Creek Drive South +Everman, Texas 76140 +Telephone: (817) 551-7018 + +} + + +INTERFACE + +USES DOS, MISC1; + +TYPE + ANSI_MODE_ = (NULL_,ANSI_,VT52_,IBM_PC_); + +CONST + ANSI_MODE : ANSI_MODE_ = ANSI_; + +PROCEDURE ANSI_CLRSCR; +{Clear the screen using ANSI control} + +PROCEDURE ANSI_CUU(VAR ii : INTEGER); +{Cursor up} + +PROCEDURE ANSI_CUD(VAR ii : INTEGER); +{Cursor down} + +PROCEDURE ANSI_CUF(VAR ii : INTEGER); +{Cursor forward or right} + +PROCEDURE ANSI_CUB(VAR ii : INTEGER); +{Cursor backward or left} + +PROCEDURE ANSI_EEOL; +{Erase to End Of Line (VT52)} + +PROCEDURE ANSI_CUH; +{Cursor home} + +PROCEDURE ANSI_CUP(line, col : INTEGER); +{Cursor position} + + + +IMPLEMENTATION + + + TYPE + Position_ = RECORD + l : BYTE; + c : BYTE; + END; + + CONST + C_pos : Position_ = (l : 0; + c : 0); + + VAR + inch : CHAR; + +{ ANSI Control sequences + +ESC [ Pn ; Pn R -> Cursor Position Report (CPR) +ESC [ Pn D -> Cursor Backward (CUB) +ESC [ Pn B -> Cursor Down (CUD) +ESC [ Pn C -> Cursor Forward (CUF) +ESC [ Pn ; Pn H -> Cursor Position (CUP) +ESC [ Pn A -> Cursor Up (CUU) +ESC [ Pn c -> Device Attributes (DA) +ESC # 8 -> Screen Alignment Display (DECALN) +ESC Z -> Identify Terminal (DECID) +ESC = -> Keypad Application Mode (DECKPAM) +ESC > -> Keypad Numeric Mode (DECKPNM) +ESC 8 -> Restore Cursor (DECRC) +ESC [ ; ; ; ; ; ; x + -> Report Terminal Parameters (DECREPTPARM) +ESC [ x -> Request Terminal Parameters (DECREQTPARM) +ESC 7 -> Save Cursor (DECSC) +ESC [ Pn ; Pn r -> Set Top and Bottom Margins (DECSTBM) +ESC [ Ps n -> Device Status Report (DSR) +ESC [ Ps J -> Erase in Display (ED) +ESC [ Ps K -> Erase in Line (EL) +ESC H -> Horizontal Tabulation Set (HTS) +ESC [ Pn ; Pn f -> Horizontal and Vertical Position (HVP) +ESC D -> Index (IND) +ESC E -> Next Line (NEL) +ESC M -> Reverse Index (RI) +ESC c -> Reset to Initial State (RIS) +ESC [ Ps ; Ps ; ... ; Ps l -> Reset Mode (RM) +ESC ( A | B | 0 | 1 | 2 -> Select Character Set (SCS) +ESC [ Ps ; ... ; Ps m -> Select Graphic Rendition (SGR) +ESC Ps ; ... Ps h -> Select Mode (SM) +ESC [ Ps g -> Tabulation Clear (TBC) + + +VT52 Mode control sequences +ESC A -> Cursor Up +ESC B -> Cursor Down +ESC C -> Cursor Right +ESC D -> Cursor Left +ESC F -> Enter Graphics Mode +ESC G -> Exit Graphics Mode +ESC H -> Cursor to Home +ESC I -> Reverse Line Feed +ESC J -> Erase To End Of Screen +ESC K -> Erase to End Of Line +ESC Y line column -> Direct Cursor Address +ESC Z -> Identify +ESC = -> Enter Alternate Keypad Mode +ESC > -> Exit Alternate Keypad Mode +ESC < -> Enter ANSI Mode + +} + +{ + CASE ANSI_MODE OF + ANSI_ : BEGIN + END; + VT52_ : BEGIN + END; + IBM_PC_ : BEGIN + END; + END; +} + + +{$V-} + + FUNCTION INT_TO_STR (ii : INTEGER):STRING; + + VAR + tstr : STRING; + + BEGIN + Str(ii,tstr); + int_to_str := tstr; + END; +{$V-} + + + PROCEDURE ANSI_CLRSCR ; +{Clear the screen using ANSI control} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket,ascii_two,'J'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'H',ascii_esc,'J',ascii_esc,'H'); + END; +{ IBM_PC_ : BEGIN + CRT.CLRSCR; + END; } + END; + c_pos.l := 0; + c_pos.c := 0; + END; {} + + + + PROCEDURE ANSI_CUU(VAR ii : INTEGER); +{Cursor up} + + BEGIN {} + IF ii <= 1 THEN ii := 1; + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket); + IF (ii > 1) THEN Write(Output,int_to_str(ii)); + Write(Output,'A'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'A'); + END; +{ IBM_PC_ : BEGIN + c_pos.l := CRT.WHEREY; + c_pos.c := CRT.WHEREX; + IF c_pos.l-ii >= 0 THEN + c_pos.l := c_pos.l - ii + ELSE + c_pos.l := 0; + CRT.GOTOXY(c_pos.c,c_pos.l); + END; } + END; + END; {} + + PROCEDURE ANSI_CUD(VAR ii : INTEGER); +{Cursor down} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket); + IF (ii > 1) THEN Write(Output,int_to_str(ii)); + Write(Output,'B'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'B'); + END; +{ IBM_PC_ : BEGIN + c_pos.l := CRT.WHEREY; + c_pos.c := CRT.WHEREX; + IF c_pos.l+ii <= 24 THEN + c_pos.l := c_pos.l + ii + ELSE + c_pos.l := 24; + CRT.GOTOXY(c_pos.c,c_pos.l); + END; } + END; + END; {} + + PROCEDURE ANSI_CUF(VAR ii : INTEGER); +{Cursor forward or right} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket); + IF (ii > 1) THEN Write(Output,int_to_str(ii)); + Write(Output,'C'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'C'); + END; +{ IBM_PC_ : BEGIN + c_pos.l := CRT.WHEREY; + c_pos.c := CRT.WHEREX; + IF c_pos.c+ii <= 79 THEN + c_pos.c := c_pos.c + ii + ELSE + c_pos.c := 79; + CRT.GOTOXY(c_pos.c,c_pos.l); + END;} + END; + END; {} + + PROCEDURE ANSI_CUB(VAR ii : INTEGER); +{Cursor backward or left} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket); + IF (ii > 1) THEN Write(Output,int_to_str(ii)); + Write(Output,'D'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'D'); + END; +{ IBM_PC_ : BEGIN + c_pos.l := CRT.WHEREY; + c_pos.c := CRT.WHEREX; + IF ((c_pos.c-ii) >= 0) THEN + c_pos.c := c_pos.c - ii + ELSE + c_pos.c := 0; + CRT.GOTOXY(c_pos.c,c_pos.l); + END; } + END; + END; {} + + PROCEDURE ANSI_EEOL; +{Erase to End Of Line (VT52)} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket,ascii_zero,'K'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'K'); + END; +{ IBM_PC_ : BEGIN + CRT.CLREOL; + END; } + END; + END; {} + + PROCEDURE ANSI_EEOS; +{Erase to End Of Screen (VT52)} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'J'); + END; +{ IBM_PC_ : BEGIN + END; } + END; + END; {} + + PROCEDURE ANSI_CUH; +{Cursor home} + + BEGIN {} + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket,'0;0','H'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'H'); + END; +{ IBM_PC_ : BEGIN + CRT.GOTOXY(BYTE(1),BYTE(1)); + END; } + END; + c_pos.l := 0; + c_pos.c := 0; + END; {} + + PROCEDURE ANSI_CUP(line, col : INTEGER); +{Cursor position} + + BEGIN {} + line := line MOD 256; + col := col MOD 256; + CASE ANSI_MODE OF + ANSI_ : BEGIN + Write(Output,ascii_esc,ascii_obracket,int_to_str(line),';', + int_to_str(col),'f'); + END; + VT52_ : BEGIN + Write(Output,ascii_esc,'Y',Chr(Ord(BYTE(line+32))),Chr(Ord( + BYTE(col+32)))); + END; +{ IBM_PC_ : BEGIN + CRT.GOTOXY(BYTE(col+1),BYTE(line+1)); + END; } + END; + c_pos.l := line; + c_pos.c := col; + END; {} + + +{ + IF (ANSI_MODE = ANSI) THEN BEGIN + END + ELSE BEGIN {VT52} + END; +} + +BEGIN {Initialization} + ASSIGN (INPUT,''); + RESET(INPUT); + ASSIGN(OUTPUT,''); + REWRITE(OUTPUT); + WRITELN(OUTPUT); + REPEAT + WRITE('Is this machine''s video 1) ANSI or 2) VT-52 compatible ?'); + READLN(inch); + inch := UPCASE(inch); + UNTIL (inch IN ['1','2','3']); + CASE inch OF + '1' : ANSI_MODE := ANSI_; + '2' : ANSI_MODE := VT52_; +{ '3' : ANSI_MODE := IBM_PC_; } + END; + ANSI_CLRSCR; +END. + + \ No newline at end of file diff --git a/THES/B61T.1 b/THES/B61T.1 new file mode 100644 index 0000000..4471c88 --- /dev/null +++ b/THES/B61T.1 @@ -0,0 +1,153 @@ +8 +1 +4 +1 +1 +2 +5 +1 +5 +8 +2 +5 +1 +4 +2 +3 +4 +3 +2 +3 +8 +4 +3 +2 +2 +3 +2 +6 +5 +2 +7 +8 +8 +2 +3 +4 +1 +4 +8 +8 +2 +2 +1 +4 +7 +8 +4 +1 +5 +1 +3 +1 +8 +8 +5 +1 +4 +6 +7 +1 +4 +8 +7 +5 +1 +4 +8 +2 +5 +5 +8 +1 +8 +4 +1 +4 +5 +4 +1 +4 +2 +8 +3 +1 +4 +8 +1 +4 +1 +7 +5 +2 +4 +2 +8 +2 +7 +6 +4 +3 +6 +3 +2 +7 +8 +5 +1 +6 +4 +2 +2 +2 +4 +7 +5 +8 +8 +6 +7 +8 +4 +6 +6 +3 +5 +4 +2 +1 +6 +2 +4 +5 +2 +2 +4 +3 +6 +8 +4 +6 +8 +7 +5 +1 +1 +2 +8 +5 +1 +1 +4 +5 + \ No newline at end of file diff --git a/THES/B61U.1 b/THES/B61U.1 new file mode 100644 index 0000000..0114896 --- /dev/null +++ b/THES/B61U.1 @@ -0,0 +1,153 @@ +5 +2 +4 +5 +3 +8 +4 +8 +5 +6 +1 +1 +8 +5 +4 +4 +3 +6 +2 +6 +4 +1 +5 +4 +5 +3 +5 +1 +8 +8 +7 +6 +5 +3 +8 +2 +7 +4 +2 +3 +4 +7 +5 +2 +8 +6 +5 +1 +3 +3 +7 +8 +1 +2 +4 +6 +8 +7 +5 +5 +2 +8 +6 +6 +4 +8 +7 +2 +2 +1 +8 +1 +4 +2 +2 +7 +6 +5 +7 +1 +6 +3 +1 +5 +7 +4 +4 +3 +6 +7 +6 +3 +3 +6 +7 +8 +8 +5 +4 +1 +3 +7 +2 +4 +2 +4 +7 +2 +5 +5 +8 +1 +3 +4 +3 +2 +3 +5 +4 +6 +2 +1 +3 +8 +7 +3 +8 +8 +5 +3 +3 +3 +5 +4 +8 +1 +3 +7 +3 +2 +7 +1 +3 +7 +5 +5 +2 +2 +4 +8 +2 +7 + \ No newline at end of file diff --git a/THES/BEETHOVN.MUS b/THES/BEETHOVN.MUS new file mode 100644 index 0000000..198d048 --- /dev/null +++ b/THES/BEETHOVN.MUS @@ -0,0 +1,209 @@ +4 +5 +4 +1 +2 +2 +7 +4 +7 +1 +5 +8 +1 +2 +3 +1 +7 +3 +4 +5 +5 +3 +6 +2 +2 +7 +4 +3 +1 +8 +2 +8 +7 +5 +1 +2 +7 +1 +8 +6 +3 +3 +5 +8 +8 +4 +5 +1 +2 +8 +3 +3 +4 +7 +8 +2 +7 +1 +3 +8 +6 +3 +4 +6 +1 +7 +2 +2 +1 +6 +6 +4 +8 +3 +3 +1 +3 +1 +4 +3 +6 +4 +7 +4 +3 +8 +6 +6 +4 +1 +6 +6 +3 +6 +2 +2 +8 +3 +7 +5 +4 +2 +4 +2 +5 +7 +1 +5 +7 +8 +8 +6 +1 +6 +5 +3 +2 +3 +8 +4 +1 +8 +4 +5 +2 +2 +7 +2 +6 +3 +5 +5 +8 +7 +3 +1 +5 +1 +7 +7 +6 +3 +5 +2 +1 +1 +8 +4 +8 +1 +6 +1 +2 +3 +6 +5 +2 +3 +7 +1 +1 +6 +3 +8 +6 +7 +3 +4 +2 +4 +6 +3 +8 +2 +6 +4 +4 +4 +2 +3 +5 +2 +8 +3 +3 +4 +6 +1 +4 +6 +2 +6 +1 +8 +7 +1 +7 +5 +6 +1 +2 +8 +8 +5 +4 +1 +4 +6 +4 \ No newline at end of file diff --git a/THES/BP_UNIT.PP b/THES/BP_UNIT.PP new file mode 100644 index 0000000..8b0478a --- /dev/null +++ b/THES/BP_UNIT.PP @@ -0,0 +1,1850 @@ + + +UNIT BP_unit; +{ +This Unit implements the necessary functions for modelling back- +propagation artificial neural network architectures. +} + +{ + +Copyright 1989 by Wesley R. Elsberry. All rights reserved. + +Commercial use of this software is prohibited without written consent of +the author. + +For information, bug reports, and updates contact + +Wesley R. Elsberry +528 Chambers Creek Drive South +Everman, Texas 76140 +Telephone: (817) 551-7018 + +} + +INTERFACE + + USES + DOS, Struct, ANN; + + CONST + mach_inf = 1E37; + exp_max = 80.0; + TAB = ^I; + Debug : BOOLEAN = FALSE; + + TYPE + + REAL = SINGLE; + + file_string_ = STRING; + + node_type_ = (Input,hidden,Output); + + weight_ptr_ = ^weight_; + + weight_ = RECORD + w, dw : REAL; + END; + + vector_node_ptr_ = ^vector_node_; + + vector_node_ = RECORD + V : REAL; + END; + + sptr_ = ^STRING; + + data_rec_ptr_ = ^data_rec_; + + data_rec_ = RECORD + s : sptr_; + n : data_rec_ptr_; + END; + + weight_node_ptr_ = ^weight_node_; + + weight_node_ = RECORD + connect : BOOLEAN; + w, dw, ldw : REAL; + END; + + BP_net_ptr_ = ^BP_net_; + + BP_node_ptr_ = ^BP_node_; + + BP_net_ = RECORD + vs, ve : DVE_ptr_; {node vector start and vector end} + ws : DVE_ptr_; {weight array} + learning_rate : REAL; + alpha : REAL; {factor for momentum term} + vi : DVE_ptr_; {input vector} + vos, voe : DVE_ptr_; {output vector} + vts, vte : DVE_ptr_; {training vector} + n_input, n_hidden, n_output : WORD; + maxerr : REAL; + errtol : REAL; + data_fname : file_string_; + data_f : TEXT; + training_iterations : INTEGER; + out_fname : file_string_; + out_f : TEXT; + wt_fname : file_string_; + wt_f : TEXT; + END; + + BP_node_ = RECORD + nt : node_type_; {Input, hidden, or output} + loc : WORD; + ni : REAL; {net input value} + delta : REAL; {delta value for node} + base : REAL; + range : REAL; + theta : REAL; + dtheta, ldtheta : REAL; + fw, bw : DVE_ptr_; {points to entries in weight_matrix} + END; + + +PROCEDURE Dump_BP_net_weights + (VAR BPN : BP_net_; VAR Fname : STRING); + +{Save weights and node bias unit values to a file} + + +PROCEDURE Set_BP_net_weights_from_file + (VAR BPN : BP_net_; VAR Fname : STRING); + +{Restore weights and node bias unit values from a file} + + +PROCEDURE BP_set_net_connects_from_file + (VAR BPN : BP_net_; VAR Fname : STRING); + +{Sets network connectivity values from a file} + + +PROCEDURE Setup_BP_net + (VAR BPN : BP_net_;VAR Fname : STRING); + +{Get data values from a text file to set up basic BP constants, sizes, and + other necessary information, or query user if filename is not valid.} + + +PROCEDURE Set_Input_vector_from_file + (VAR BPN : BP_net_); + +{Get data values from a text file to fill input vector.} + + +PROCEDURE Set_Training_vector_from_file + (VAR BPN : BP_net_); + +{Get data values from a text file to fill training vector.} + + +PROCEDURE BP_Feed_forward + (VAR BPN : BP_net_); + +{Present values to network and propagate values forward, set the output + vector.} + + +PROCEDURE BP_train_presentation + (VAR BPN : BP_net_); + +{Present values to network, propagate forward, set output, compare output + to training, back-propagate, collect statistics but do not change weights.} + + +PROCEDURE BP_train_and_change + (VAR BPN : BP_net_); + +{Present values to network, propagate forward, set output, compare output + to training, back-propagate, collect statistics, change weights, and reset + statistic variables.} + + +PROCEDURE BP_change + (VAR BPN : BP_net_); + +{Change weights using current statistics and reset statistics.} + + +PROCEDURE BP_dump_net + (VAR BPN : BP_net_); + +{Dump net parameters, node activities, and weights for inspection.} + + +FUNCTION BP_net_error + (VAR BPN : BP_net_):REAL; + +{Returns the largest error from the output nodes} + + +PROCEDURE Display_weights + (BPN : BP_net_); + +{Display of the current weight values for the network} + + +{----------------------------------------------------------------------} + +IMPLEMENTATION + +{----------------------------------------------------------------------} + +{Private, internal functions} + + FUNCTION max (r1, r2 : REAL):REAL; + + BEGIN + IF r1 >= r2 THEN max := r1 + ELSE max := r2; + END; + +{----------------------------------------------------------------------} + + + PROCEDURE Dump_BP_net_weights (VAR BPN : BP_net_; + VAR Fname : STRING); +{Save weights and node bias unit values to a file} +{ +Preface vector length with !V +Preface weight vectors with !W +Preface bias unit vector with !T +} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, jj, m, n : WORD; + inch : CHAR; + done : BOOLEAN; + tp1 : DVE_ptr_; + ss : STRING; + + BEGIN + n := BPN.n_input + BPN.n_hidden + BPN.n_output; + +(* + ss := FSEARCH(Fname,GETENV('PATH')); + + IF LENGTH(ss) = 0 THEN BEGIN + WRITELN('**ERROR** File does not exist'); + EXIT; + END; *) + + BPN.wt_fname := Fname; + Assign(BPN.wt_f,Fname); + Rewrite(BPN.wt_f); + + done := FALSE; + + {Write vector length} + Writeln(BPN.wt_f,'!V ',n:1); + + FOR jj := 1 TO n DO BEGIN + Write(BPN.wt_f,'!W '); + FOR ii := 1 TO n DO BEGIN + tp1 := Find_element_matrix(ii,jj,BPN.ws); + IF wnp_(tp1^.dptr)^.connect THEN Write(BPN.wt_f,wnp_(tp1^.dptr)^.w: + 4:4,' ') + ELSE Write(BPN.wt_f,0.0:4:4,' '); + END; + Writeln(BPN.wt_f); + END; + + Write(BPN.wt_f,'!T '); + FOR ii := 1 TO n DO BEGIN + tp1 := Find_element_DVE(ii,BPN.vs); + Write(BPN.wt_f,bpnp_(tp1^.dptr)^.theta:4:4,' '); + END; + Writeln(BPN.wt_f); + + Writeln(BPN.wt_f,'!Z '); + + Close(BPN.wt_f); + END; {Dump_BP_net_weights} + + + PROCEDURE Set_BP_net_weights_from_file (VAR BPN : BP_net_; + VAR Fname : STRING); + {Restore weights and node bias unit values from a file} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, jj, m, n : WORD; + rr : REAL; + tp1, wp1, wp2 : DVE_ptr_; + inch : CHAR; + done : BOOLEAN; + ss : STRING; + + BEGIN {} + n := BPN.n_input + BPN.n_hidden + BPN.n_output; + + ss := FSEARCH (Fname,GETENV('PATH')); + + IF (Length(ss) = 0) THEN BEGIN + Writeln ('**ERROR** File does not exist'); + EXIT; + END; + + Assign (BPN.wt_f,ss); + Reset (BPN.wt_f); + + done := FALSE; + + {Find vector length, compare to net vector length} + + REPEAT + REPEAT {find command} + Read (BPN.wt_f,inch); + UNTIL (inch = '!') OR Eof(BPN.wt_f); + {} + Read (BPN.wt_f,inch); + UNTIL (UpCase (inch) = 'V') OR Eof (BPN.wt_f); + + IF Eof (BPN.wt_f) THEN BEGIN + EXIT; + END; + + Read (BPN.wt_f,inch); + Read (BPN.wt_f,m); + + IF (m <> n) THEN BEGIN {Vector lengths don't match, quit} + EXIT; + END; + + wp1 := BPN.ws; + REPEAT {get net params} + REPEAT {find command} + Read (BPN.wt_f,inch); + UNTIL (inch = '!'); {} + Read (BPN.wt_f,inch); + CASE UpCase (inch) OF + 'T' : BEGIN {get bias values} + Read (BPN.data_f, inch); + FOR ii := 1 TO n DO BEGIN + tp1 := Find_element_DVE (ii,BPN.vs); + Read (BPN.wt_f,rr); + bpnp_(tp1^.dptr)^.theta := rr; + END; + END; {} + 'W' : BEGIN {get weights} + IF wp1 <> NIL THEN BEGIN + Read (BPN.data_f,inch); + FOR ii := 1 TO n DO BEGIN + wp2 := Find_element_DVE (ii,wp1); + Read (BPN.wt_f,rr); + wnp_(wp2^.dptr)^.w := rr; + END; {For ii} + wp1 := wp1^.down; + END; + END; {} + 'Z' : DONE := TRUE; + ELSE + BEGIN + DONE := TRUE; + END; + END; + UNTIL (done OR Eof (BPN.wt_f)); + {} + END; {set_BP_net_weights_from_file} + + + PROCEDURE BP_set_net_connects_from_file (VAR BPN : BP_net_; + VAR Fname : STRING); + {Sets network connectivity values from a file} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, jj, kk, m, n : WORD; + tp1, wp1, wp2 : DVE_ptr_; + inch : CHAR; + done : BOOLEAN; + ss : STRING; + cfile : TEXT; + + BEGIN {} + n := BPN.n_input + BPN.n_hidden + BPN.n_output; + + ss := FSEARCH (Fname,GETENV('PATH')); + + IF (Length(ss) = 0) THEN BEGIN + Writeln ('**ERROR** File does not exist'); + EXIT; + END; + + Assign (cfile,ss); + Reset (cfile); + + done := FALSE; + + {Find vector length, compare to net vector length} + + REPEAT + REPEAT {find command} + Read (cfile,inch); + UNTIL (inch = '!') OR Eof(cfile); + {} + Read (cfile,inch); + UNTIL (UpCase (inch) = 'V') OR Eof (cfile); + + IF Eof (cfile) THEN BEGIN + EXIT; + END; + + Read (cfile,inch); + Read (cfile,m); + + IF (m <> n) THEN BEGIN {Vector lengths don't match, quit} + EXIT; + END; + + wp1 := BPN.ws; + REPEAT {get net params} + REPEAT {find command} + Read (cfile,inch); + UNTIL (inch = '!'); {} + Read (cfile,inch); + CASE UpCase (inch) OF + 'C' : BEGIN {get weights} + IF wp1 <> NIL THEN BEGIN + Read (cfile,inch); + FOR ii := 1 TO n DO BEGIN + wp2 := Find_element_DVE (ii,wp1); + Read (cfile,kk); + wnp_(wp2^.dptr)^.connect := (kk = 1); + END; {For ii} + wp1 := wp1^.down; + END; + END; {} + 'Z' : DONE := TRUE; + ELSE + BEGIN + DONE := TRUE; + END; + END; + UNTIL (done OR Eof (cfile)); + {} + END; {BP_set_net_connects_from_file} + + + PROCEDURE Dump_node (net : BP_net_; + node : BP_node_ptr_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + BEGIN + IF (debug) THEN {} + BEGIN + Writeln ('DUMP_NODE'); + Writeln (NET.OUT_F,'DUMP_NODE'); + END; + IF (node <> NIL) THEN BEGIN + CASE node^.nt OF + Input : BEGIN + Write (net.out_f,'INPUT'); + Write ('INPUT'); + END; + hidden : BEGIN + Write (net.out_f,'HIDDEN'); + Write ('HIDDEN'); + END; + Output : BEGIN + Write (net.out_f,'OUTPUT'); + Write ('OUTPUT'); + END; + END; + Write (net.out_f,tab,'LOC : ',NODE^.LOC); + Write ('LOC : ',NODE^.LOC); + Writeln (net.out_f,tab,'ADDR : ',Seg(NODE),':',Ofs(NODE)); + Writeln (tab,'ADDR : ',Seg(NODE),':',Ofs(NODE)); + Write (net.out_f,'NI : ',node^.ni:8); + Write ('NI : ',node^.ni:8); + Writeln (net.out_f,tab,'DELTA : ',NODE^.DELTA:8); + Writeln (tab,'DELTA : ',NODE^.DELTA:8); + Write (net.out_f,'BASE : ',NODE^.BASE:8); + Write ('BASE : ',NODE^.BASE:8); + Writeln (net.out_f,tab,'RANGE : ',NODE^.RANGE:8); + Writeln (tab,'RANGE : ',NODE^.RANGE:8); + Write (net.out_f,'THETA : ',NODE^.THETA:8); + Write ('THETA : ',NODE^.THETA:8); + Writeln (net.out_f,tab,'DTHETA : ',NODE^.DTHETA:8,tab, + 'LDTHETA : ', + NODE^.LDTHETA:8); + Writeln (tab,'DTHETA : ',NODE^.DTHETA:8,tab,'LDTHETA : ',NODE^. + LDTHETA:8); + Writeln (net.out_f,'FW : ',Seg(NODE^.FW),':', Ofs(NODE^.FW), + tab,'BW : ', Seg(NODE^.BW),':',Ofs(NODE^.BW)); + Writeln ('FW : ',Seg(NODE^.FW),':', Ofs(NODE^.FW),tab,'BW : ', + Seg(NODE^.BW),':',Ofs(NODE^.BW)); + Writeln (net.out_f); + Writeln; + END; + IF (debug) THEN BEGIN + Writeln ('END DUMP_NODE'); + Writeln (NET.OUT_F,'END DUMP_NODE'); + END; + END; + + + PROCEDURE Display_weights (BPN : BP_net_); + {Display of the current weight values for the network} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + twpd, twpa : DVE_ptr_; + wptr : DVE_ptr_; + + BEGIN {} + IF debug THEN BEGIN + Writeln ('DISPLAY_WEIGHTS'); + Writeln (BPN.OUT_F,'DISPLAY_WEIGHTS'); + END; + twpd := BPN.ws; + twpa := BPN.ws; + WHILE (twpd <> NIL) DO BEGIN{} + WHILE (twpa <> NIL) DO BEGIN + {} + wptr := twpa^.dptr; + IF (wnp_(wptr)^.connect) THEN BEGIN + Write (BPN.out_f,wnp_(wptr)^.w:5:1,' '); + Write (wnp_(wptr)^.w:5:1,' '); + END + ELSE {} + BEGIN + Write (BPN.out_f,' --- '); + Write (' --- '); + END; + twpa := twpa^.right; + END; {} + Writeln (BPN.out_f); + Writeln ; + twpd := twpd^.down; + twpa := twpd; + END; {} + Writeln (BPN.out_f,'End of weights'); + Writeln ('End of weights'); + Writeln; + Writeln; + IF (debug) THEN {} + BEGIN + Writeln ('END DISPLAY_WEIGHTS'); + Writeln (BPN.OUT_F,'END DISPLAY_WEIGHTS'); + END; + Flush (BPN.out_f); + END; {} + + + PROCEDURE Display_Vector (vp : DVE_ptr_; + N : INTEGER; + NET : BP_net_); +{} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii : INTEGER; + vptr : vector_node_ptr_; + + BEGIN {} + IF debug THEN BEGIN + Writeln ('DISPLAY_VECTOR'); + Writeln (NET.OUT_F,'DISPLAY_VECTOR'); + END; + FOR II := 1 TO N DO BEGIN {} + vptr := vp^.dptr; + Write (net.out_f,vptr^.V:8,' '); + Write (vptr^.V:8,' '); + vp := vp^.right; + END; + Writeln (net.out_f); + Writeln; + IF (debug) THEN {} + BEGIN + Writeln ('END DISPLAY_VECTOR'); + Writeln (NET.OUT_F,'END DISPLAY_VECTOR'); + END; + END; {} + + FUNCTION BP_net_error (VAR BPN : BP_net_):REAL; +{Returns the largest error from the output nodes} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + rr : REAL; + tp, vp1, vp2 : DVE_ptr_; + ii, n : INTEGER; + + BEGIN + rr := 0; + n := BPN.n_input + BPN.n_hidden + BPN.n_output; + vp1 := BPN.vos; + vp2 := BPN.vts; + FOR ii := 1 TO BPN.n_output DO BEGIN + IF (vp1^.dptr <> NIL) AND (vp2^.dptr <> NIL) THEN BEGIN + rr := max (ABS(rr), + ABS(vnp_(vp2^.dptr)^.v - vnp_(vp1^.dptr)^.v)); + IF vp1^.right <> NIL THEN vp1 := vp1^.right; + IF vp2^.right <> NIL THEN vp2 := vp2^.right; + END + ELSE BEGIN + END; + END; + + BP_net_error := ABS(rr); + END; + + PROCEDURE Allocate_IO_vectors (VAR net : BP_net_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, N : WORD; + + BEGIN + IF debug THEN BEGIN + Writeln ('ALLOCATE_IO_VECTORS'); + Writeln (NET.OUT_F,'ALLOCATE_IO_VECTORS'); + END; + N := net.n_input + net.n_hidden + net.n_output; + net.vi := Create_DVE_vector (net.n_input, SizeOf(vector_node_)); + net.vos := Create_DVE_vector (net.n_output, SizeOf(vector_node_)); + net.vts := Create_DVE_vector (net.n_output, SizeOf(vector_node_)); + net.voe := Find_element_DVE (net.n_output, net.vos); + net.vte := Find_element_DVE (net.n_output, net.vts); + IF (debug) THEN {} + BEGIN + Writeln ('END ALLOCATE_IO_VECTORS'); + Writeln (NET.OUT_F,'END ALLOCATE_IO_VECTORS'); + END; + END; + + PROCEDURE Allocate_node_vector (VAR net : BP_net_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, cnt, N : INTEGER; + Temp : BP_node_ptr_; + nptr : DVE_ptr_; + low, high : REAL; + ns : BP_node_; + + BEGIN + cnt := 1; + N := net.n_input + net.n_hidden + net.n_output; + IF debug THEN BEGIN + Writeln ('ALLOCATE_NODE_VECTOR'); + Writeln (NET.OUT_F,'ALLOCATE_NODE_VECTOR'); + END; + net.vs := Create_DVE_vector (net.n_input, SizeOf (BP_node_)); + net.ve := Find_element_DVE (net.n_input, net.vs); + nptr := net.vs; + FOR ii := 1 TO net.n_input DO BEGIN + temp := nptr^.dptr; + Temp^.loc := cnt; + cnt := cnt + 1; + Temp^.nt := Input; {set node type} + Temp^.ni := 0; {init net input} + Temp^.fw := NIL; {no weight yet} + Temp^.bw := NIL; {no weight yet} + Temp^.delta := 0; + Temp^.base := 0; + Temp^.range := 1; + Temp^.theta := 0; + Temp^.dtheta := 0; + Temp^.ldtheta := 0; + nptr := nptr^.right; + END; {FOR} + net.ve^.right := Create_DVE_vector (net.n_hidden, + SizeOf(BP_node_)); + net.ve^.right^.left := net.ve; + nptr := net.ve^.right; + net.ve := Find_element_DVE (net.n_input + net.n_hidden, net.vs); + + FOR II := 1 TO net.n_hidden DO BEGIN + temp := nptr^.dptr; + Temp^.loc := cnt; + cnt := cnt + 1; + Temp^.nt := hidden; {set node type} + Temp^.ni := 0; {init net input} + Temp^.fw := NIL; {no weight yet} + Temp^.bw := NIL; {no weight yet} + Temp^.delta := 0; + Temp^.base := 0; + Temp^.range := 1; + Temp^.theta := gaussian_noise (0,0.25); + Temp^.dtheta := 0; + Temp^.ldtheta := 0; + nptr := nptr^.right; + END; + net.ve^.right := Create_DVE_vector (net.n_output, + SizeOf(BP_node_)); + net.ve^.right^.left := net.ve; + nptr := net.ve^.right; + net.ve := Find_element_DVE (net.n_input + net.n_hidden + + net.n_output,net.vs); + + FOR II := 1 TO net.n_output DO BEGIN + temp := nptr^.dptr; + Temp^.loc := cnt; + cnt := cnt + 1; + Temp^.nt := Output; {set node type} + Temp^.ni := 0; {init net input} + Temp^.fw := NIL; {no weight yet} + Temp^.bw := NIL; {no weight yet} + Temp^.delta := 0; + Temp^.base := 0 {low}; + Temp^.range := 1 {high - low}; + Temp^.theta := gaussian_noise (0,0.25); + Temp^.dtheta := 0; + Temp^.ldtheta := 0; + nptr := nptr^.right; + END; + IF (debug) THEN BEGIN + Writeln ('END ALLOCATE_NODE_VECTOR'); + Writeln (NET.OUT_F,'END ALLOCATE_NODE_VECTOR'); + END; + END; + + + PROCEDURE Allocate_weight_matrix (VAR net : BP_net_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + ii, jj, N : WORD; + temp : DVE_ptr_; + tl, tc, tls, tcs : weight_node_ptr_; + Vt : Vector_node_ptr_; + cnt : INTEGER; + + BEGIN + IF debug THEN BEGIN + Writeln ('ALLOCATE_WEIGHT_MATRIX'); + Writeln (NET.OUT_F,'ALLOCATE_WEIGHT_MATRIX'); + END; + cnt := 1; + N := net.n_input + net.n_hidden + net.n_output; + net.ws := create_matrix (n,n,SizeOf(weight_node_)); + + FOR ii := 1 TO n DO BEGIN + FOR jj := 1 TO n DO BEGIN + temp := Find_element_matrix(ii, jj, net.ws); + IF temp <> NIL THEN BEGIN + wnp_(temp^.dptr)^.connect := FALSE; + wnp_(temp^.dptr)^.w := 2 * Random - 1; + {random weights, -1 < w < 1 } + wnp_(temp^.dptr)^.dw := 0; + wnp_(temp^.dptr)^.ldw := 0; + END; {IF temp <> NIL} + END; + END; + IF (debug) THEN {} + BEGIN + Writeln ('END ALLOCATE_WEIGHT_MATRIX'); + Writeln (NET.OUT_F,'END ALLOCATE_WEIGHT_MATRIX'); + END; + END; + + PROCEDURE Link_weights_to_nodes (VAR net : BP_net_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + Start, TempD, TempA : DVE_ptr_; + Vt : DVE_ptr_; + ii, jj, N : INTEGER; + + BEGIN + {Link to node vector} + IF debug THEN BEGIN + Writeln ('LINK_WEIGHTS_TO_NODES'); + Writeln (NET.OUT_F,'LINK_WEIGHTS_TO_NODES'); + END; + N := net.n_input + net.n_hidden + net.n_output; + Start := net.ws; + TempD := Start; + TempA := Start; + Vt := net.vs; + FOR ii := 1 TO N DO BEGIN + bpnp_(Vt^.dptr)^.fw := TempD; + TempD := TempD^.down; + bpnp_(Vt^.dptr)^.bw := TempA; + TempA := TempA^.right; + Vt := Vt^.right; + END; + IF (debug) THEN {} + BEGIN + Writeln ('END LINK_WEIGHTS_TO_NODES'); + Writeln (NET.OUT_F,'END LINK_WEIGHTS_TO_NODES'); + END; + END; {Link_weights_to_nodes} + + PROCEDURE Display_node_type (VAR net : BP_net_); +{} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + tp : DVE_ptr_; + N, ii : INTEGER; + + BEGIN {} + IF debug THEN BEGIN + Writeln ('DISPLAY_NODE_TYPE'); + Writeln (NET.OUT_F,'DISPLAY_NODE_TYPE'); + END; + tp := net.vs; + N := net.n_input + net.n_hidden + net.n_output; + FOR ii := 1 TO n DO BEGIN {} + CASE bpnp_(tp^.dptr)^.nt OF + Input : BEGIN + Write (net.out_f,'I'); + Write ('I'); + END; + hidden : BEGIN + Write (net.out_f,'H'); + Write ('H'); + END; + Output : BEGIN + Write (net.out_f,'O'); + Write ('O'); + END; + END; + TP := tp^.right; + END; {} + Writeln (net.out_f); + Writeln ; + IF (debug) THEN {} + BEGIN + Writeln ('END DISPLAY_NODE_TYPE'); + Writeln (NET.OUT_F,'END DISPLAY_NODE_TYPE'); + END; + END; {} + + PROCEDURE Display_node_deltas (VAR net : BP_net_); +{} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + tp : DVE_ptr_; + N, ii : INTEGER; + + BEGIN {} + IF debug THEN BEGIN + Writeln ('DISPLAY_NODE_DELTAS'); + Writeln (NET.OUT_F,'DISPLAY_NODE_DELTAS'); + END; + tp := net.vs; + N := net.n_input + net.n_hidden + net.n_output; + FOR ii := 1 TO n DO BEGIN {} + TP := tp^.right; + END; {} + IF (debug) THEN {} + BEGIN + Writeln ('END DISPLAY_NODE_DELTAS'); + Writeln (NET.OUT_F,'END DISPLAY_NODE_DELTAS'); + END; + END; {} + + PROCEDURE set_connectivity (VAR net : BP_net_); + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + VAR + wpt : DVE_ptr_; + tvd, tva : DVE_ptr_; + ii, jj, n : INTEGER; + + BEGIN + IF debug THEN BEGIN + Writeln ('SET_CONNECTIVITY'); + Writeln (NET.OUT_F,'SET_CONNECTIVITY'); + END; + n := net.n_input + net.n_hidden + net.n_output; + tvd := net.vs; {beginning of node vector} + tva := net.vs; + wpt := bpnp_(tvd^.dptr)^.fw; + {display_node_type (net);} + FOR ii := 1 TO n DO BEGIN + FOR jj := 1 TO n DO BEGIN + CASE bpnp_(tvd^.dptr)^.nt OF + Input : BEGIN + wnp_(wpt^.dptr)^.connect := FALSE; + END; + hidden : BEGIN + IF (bpnp_(tva^.dptr)^.nt = Input) THEN BEGIN + wnp_(wpt^.dptr)^.connect := TRUE; + END + ELSE BEGIN + wnp_(wpt^.dptr)^.connect := FALSE; + END; + END; + Output : BEGIN + IF (bpnp_(tva^.dptr)^.nt = hidden) THEN BEGIN + wnp_(wpt^.dptr)^.connect := TRUE; + END + ELSE BEGIN + wnp_(wpt^.dptr)^.connect := FALSE; + END; + END; + END; {case} + wpt := wpt^.right; + tva := tva^.right; + END; + tvd := tvd^.right; + tva := net.vs; + wpt := bpnp_(tvd^.dptr)^.fw; + END; + IF (debug) THEN {} + BEGIN + Writeln ('END SET_CONNECTIVITY'); + Writeln (NET.OUT_F,'END SET_CONNECTIVITY'); + END; + END; + + PROCEDURE Display_output (VAR net : BP_net_); + {} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + BEGIN {} + IF debug THEN BEGIN + Writeln ('DISPLAY_OUTPUT'); + Writeln (NET.OUT_F,'DISPLAY_OUTPUT'); + END; + display_vector (net.vos,net.n_output,net); + IF (debug) THEN {} + BEGIN + Writeln ('END DISPLAY_OUTPUT'); + Writeln (NET.OUT_F,'END DISPLAY_OUTPUT'); + END; + END; {} + + + FUNCTION BP_error_measure (Output_vector_ptr : DVE_ptr_; + Training_vector_ptr : DVE_ptr_; + net : BP_net_): REAL; + + BEGIN + END; {BP_error_measure} + + +{----------------------------------------------------------------------} + + PROCEDURE BP_set_net_defaults (VAR net : BP_net_); +{} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + BEGIN {} + WITH net DO BEGIN {} + vs := NIL; + ve := NIL; + ws := NIL; + vi := NIL; + vos := NIL; + voe := NIL; + vts := NIL; + vte := NIL; + maxerr := 0.2; + errtol := 0.1; + learning_rate := 0.5; + alpha := 0.9; {factor for momentum term} + n_input := 1; + n_hidden := 1; + n_output := 1; +{ data_fname := 'BP.DAT';} + training_iterations := 1; + out_fname := 'BP.OUT'; + wt_fname := ''; + END; {} + END; {} + + PROCEDURE BP_get_net_params_from_user (VAR net : BP_net_); +{} + + TYPE + bpnp_ = BP_node_ptr_; + wnp_ = weight_node_ptr_; + vnp_ = vector_node_ptr_; + + BEGIN {} + Write ('File to output run data to : '); + Readln (net.out_fname); + Assign (net.out_f,net.out_fname); + Rewrite (net.out_f); + {learning rate} + Write ('Learning rate? : '); + Readln (net.learning_rate); + Writeln (NET.OUT_F,'Learning rate : ',net.learning_rate:5:3); + Writeln ('Learning rate : ',net.learning_rate:5:3); + {momentum factor} + Write ('Momentum factor? : '); + Readln (net.alpha); + Writeln (NET.OUT_F,'Momentum factor : ',net.alpha:5:3); + Writeln ('Momentum factor : ',net.alpha:5:3); + {# of input nodes?} {BP_INPUT_NODES_NUM} + Write ('Number of input nodes? : '); + Readln (net.n_input); + Writeln (NET.OUT_F,'# of input nodes : ',net.n_input:3); + Writeln ('# of input nodes : ',net.n_input:3); + {# of hidden nodes in vector} + Write ('Number of hidden nodes? : '); + Readln (net.n_hidden); + Writeln (NET.OUT_F,'# of hidden nodes : ',net.n_hidden:3); + Writeln ('# of hidden nodes : ',net.n_hidden:3); + {# of output nodes} + Write ('Number of output nodes? : '); + Readln (net.n_output); + Writeln (NET.OUT_F,'# of output nodes : ',net.n_output:3); + Writeln ('# of output nodes : ',net.n_output:3); + {error tolerance} + Write ('Error tolerance? : '); + Readln (net.errtol); + Writeln (NET.OUT_F,'Error tolerance : ',net.errtol:5:3); + Writeln ('Error tolerance : ',net.errtol:5:3); + Writeln; + Write ('Name of data file : '); + Readln (net.data_fname); + Writeln (NET.OUT_F,'Data file : ',net.data_fname:15); + Writeln ('Data file : ',net.data_fname:15); + Write ('Number of training runs? : '); + Readln (net.training_iterations); + Writeln (NET.OUT_F,'# of iterations : ', + net.training_iterations:3); + Writeln ('# of iterations : ',net.training_iterations:3); + Writeln; + END; {} + + PROCEDURE BP_set_net_params_from_file (VAR net : BP_net_; + VAR Fname : STRING); +{ +Use the following format for data entries in this section: + +!