[Inquiry] Theme One Program

[Jon Awbrey]

o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o

TOP.  Note 1

o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o

{ compiler: turbo pascal, version 5.0, }
{ (c) 1987, 1988 borland international }
{$M 53248,0,655360} { stack and heap   }
{$B+} { boolean complete evaluation on }

{ project: theme
  segment: learner + modeler                         copyright: 1984 - 2003
  version: 1                                                by: jon awbrey }

program theme;

uses    crt;

const   links = '(' ;  right = ')' ;  enter = ^m ;  ender = ^z ;
        comma = ',' ;  point = '.' ;  estab = ^i ;  escap = ^[ ;
        blank = ' ' ;  quote = '`' ;  elide = ^h ;  erase = ^x ;
        aster = '*' ;  minus = '-' ;  empty = '' ;    nul = #0 ;

type    mode = (null, moot, firm);
        cast = set of char;
        numb = 0..maxint;
        info = string;

        idea = ^form;
        form = record
                sign: char;
                as, up, on, by: idea;
                code: numb
               end;

var     here: idea;
        size,
        trim: numb;
         con: text;

procedure video (what: mode);
begin
 case what of
  null: textcolor (0);
  moot: textcolor (7);
  firm: textcolor (14)
 end
end;

procedure stop;
var mark: char;
begin
 write ('< press any key > ');  repeat until keypressed;
 mark := readkey
end;

function just (this: idea): idea;
begin
 just := nil
end;

function clear (this: idea): idea;
begin
 clear := this;  clrscr
end;

function clean (this: idea): idea;
begin
 clean := just (clear (this))
end;

function flint (this: idea): idea;
var here: idea;

function hold (this: idea): idea;
begin
 hold := this;  stop
end;

function wait (this: idea): idea;
begin
 wait := this;  delay (256)
end;

function dim (this: idea): idea;
begin
 dim := this;  video (moot)
end;

function vid (this: idea): idea;
begin
 vid := this;  video (firm)
end;

function dash (this: idea): idea;
begin
 dash := this;  clreol
end;

function lash (this: idea): idea;
begin
 lash := this;  write (enter)
end;

function quash (this: idea): idea;
begin
 quash := dash (lash (this))
end;

function space (var thou: text;
		    this: idea): idea;
begin
 space := this;  write (thou, blank)
end;

function skip (var thou: text;
                    tab: numb;
                   this: idea): idea;
var col: numb;
begin
 skip := this;  for col := 1 to tab do write (thou, blank)
end;

function pass (var thou: text;
                   line: info;
                   this: idea): idea;
begin
 pass := this;  write (thou, line)
end;

function turn (this: idea): idea;
begin
 turn := this;  writeln
end;

function verse (var thou: text;
                    line: info;
                    this: idea): idea;
begin
 verse := this;  writeln (thou, line)
end;

function return (var thou: text;
		     this: idea): idea;
begin
 return := this;  writeln (thou)
end;

function tort (this: idea): idea;
begin
 tort := this;  write ('))')
end;

function till (this: idea): idea;
begin
 till := this;  write (' ... ')
end;

function at (row, col: numb;
                 this: idea): idea;
begin
 at := this;  gotoxy (col, row)
end;

function check (this: idea): idea;
begin
 check := this;  write (memavail, ' bytes')
end;

function memcheck (this: idea): idea;
begin
 memcheck := at (1, 48, this);
 write ('< free memory : ', memavail : 8, ' bytes >')
end;

function upon (thus, that, this: idea): idea;
var here: idea;
begin
 here := nil;
 if thus <> nil then here := that else here := this;
 upon := here
end;

function obvert (that, this: idea): idea;
begin
 obvert := that
end;

function revert (that, this: idea): idea;
begin
 revert := this
end;

function covert (that, this: idea): idea;
begin
 covert := upon (that, nil, this)
end;

function divert (that, this: idea): idea;
begin
 divert := upon (that, this, nil)
end;

function equity (that, this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then if that <> nil then
  if that = this then here := this;
 equity := here
end;

function tap (var thou: text): char;
var mark: char;
begin
 read (thou, mark);
 tap := mark
end;

function pat (var thou: text;
                  mark: char): char;
begin
 write (thou, mark);
 pat := mark
end;

function apt (mark: char;
              this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then
  if mark = this^.sign then here := this;
 apt := here
end;

function trap (var thou: text;
                   this: idea): idea;
begin
 trap := this;
 if this <> nil then read (thou, this^.sign)
end;

function part (var thou: text;
                   this: idea): idea;
begin
 part := this;
 if this <> nil then write (thou, this^.sign)
end;

function rapt (that, this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then if that <> nil then
  if that^.sign = this^.sign then here := this;
 rapt := here
end;

function nip (var thou: text): numb;
var what: numb;
    mark: char;
begin
 read (thou, what);
 if not eoln (thou) then mark := tap (thou);
 nip := what
end;

function pin (var thou: text;
                  what: numb): numb;
begin
 write (thou, what, blank);
 pin := what
end;

function knab (var thou: text;
                   what: mode): numb;
begin
 if what = null then knab := 0 else knab := nip (thou)
end;

function spin (var thou: text;
                   this: idea): idea;
begin
 spin := this;
 if this <> nil then write (thou, this^.code)
end;

function score (var thou: text;
                    span: numb;
                    this: idea): idea;
begin
 score := this;
 if this <> nil then write (thou, this^.code : span)
end;

function pose (var thou: text;
                   this: idea): idea;
begin
 pose := this;
 if this <> nil then write (thou, this^.sign, this^.code, blank)
end;

function anon (what: numb): numb;
begin
 inc (what);  anon := what
end;

function anew (var what: numb): numb;
begin
 inc (what);  anew := what
end;

function alow (what: numb): numb;
begin
 alow := what - 1
end;

function abye (var what: numb): numb;
begin
 what := what - 1;  abye := what
end;

function arch (this: idea): char;
var mark: char;
begin
 mark := blank;
 if this <> nil then mark := this^.sign;
 arch := mark
end;

function ante (this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then here := this^.as;
 ante := here
end;

function nigh (this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then here := this^.up;
 nigh := here
end;

function trip (this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then here := this^.on;
 trip := here
end;

function next (this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then here := this^.by;
 next := here
end;

function reck (this: idea): numb;
var what: numb;
begin
 what := 0;
 if this <> nil then what := this^.code;
 reck := what
end;

function scrip (this: idea;
                mark: char): idea;
begin
 scrip := this;
 if this <> nil then this^.sign := mark
end;

function asset (this, that: idea): idea;
begin
 asset := this;
 if this <> nil then this^.as := that
end;

function upset (this, that: idea): idea;
begin
 upset := this;
 if this <> nil then this^.up := that
end;

function onset (this, that: idea): idea;
begin
 onset := this;
 if this <> nil then this^.on := that
end;

function beset (this, that: idea): idea;
begin
 beset := this;
 if this <> nil then this^.by := that
end;

function inset (this: idea;
                what: numb): idea;
begin
 inset := this;
 if this <> nil then this^.code := what
end;

function peg (     mark: char;
 when, thus, that, this: idea;
                   what: numb): idea;
var here: idea;
begin
 new (here);  with here^ do
  begin
   sign := mark;
     as := when;  up := thus;  on := that;  by := this;
   code := what
  end;
 peg := here
end;

function dot: idea;
begin
 dot := peg (nul, nil, nil, nil, nil, 0)
end;

function eye: idea;
begin
 eye := peg (blank, nil, nil, nil, nil, 0)
end;

function tag (mark: char): idea;
begin
 tag := peg (mark, nil, nil, nil, nil, 0)
end;

function tog (this: idea): idea;
begin
 tog := peg (blank, this, nil, nil, nil, 0)
end;

function tip: idea;
var here: idea;
begin
 here := tag (readkey);
 with here^ do if sign = nul then on := tip;
 tip := here
end;

function cog (this: idea): idea;
begin
 cog := beset (this, this)
end;

function nib: idea;
begin
 nib := cog (dot)
end;

function nob: idea;
begin
 nob := cog (eye)
end;

function bud (mark: char): idea;
begin
 bud := cog (tag (mark))
end;

function nub (this: idea): idea;
begin
 nub := cog (tog (this))
end;

function cue (this: idea): idea;
begin
 cue := upset (nib, this)
end;

function key (this: idea): idea;
begin
 key := upset (nob, this)
end;

function jog (this: idea): idea;
begin
 jog := inset (this, anon (reck (this)))
end;

function belong (such: cast;
                 this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then
  if arch (this) in such then here := this;
 belong := here
end;

function beside (such: cast;
                 this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then
  if not (arch (this) in such) then here := this;
 beside := here
end;

function class (this: idea): idea;
begin
 class := this;
 if this <> nil then
  case arch (this) of
   blank, enter: this := scrip (this, comma);
   escap, ender: this := scrip (this, point)
  end
end;

function clash (var thou: text;
                    this: idea): idea;
begin
 clash := this;
 if this <> nil then
  case arch (this) of
   comma: this := pass (thou, links, this);
   point: this := pass (thou, right, this)
  end
end;

function lief (this: idea): idea;
begin
 lief := apt (links, this)
end;

function rest (this: idea): idea;
begin
 rest := apt (right, this)
end;

function cope (this: idea): idea;
begin
 cope := apt (comma, this)
end;

function punt (this: idea): idea;
begin
 punt := apt (point, this)
end;

function bank (this: idea): idea;
begin
 bank := apt (blank, this)
end;

function balk (this: idea): idea;
begin
 balk := belong ([blank, links], this)
end;

function bark (this: idea): idea;
begin
 bark := belong ([blank, right], this)
end;

function blur (this: idea): idea;
begin
 blur := belong ([blank, links, right], this)
end;

function entab (this: idea): idea;
begin
 entab := apt (estab, this)
end;

function scape (this: idea): idea;
begin
 scape := apt (escap, this)
end;

function cleft (this: idea): idea;
begin
 cleft := belong ([comma, links], this)
end;

function grain (this: idea): idea;
begin
 grain := beside ([comma, links], this)
end;

function crest (this: idea): idea;
begin
 crest := belong ([comma, right], this)
end;

function glyph (this: idea): idea;
begin
 glyph := beside ([comma, right], this)
end;

function tare (this: idea): idea;
begin
 tare := belong ([comma, links, right], this)
end;

function gram (this: idea): idea;
begin
 gram := beside ([comma, links, right], this)
end;

function atom (this: idea): idea;
begin
 atom := beside ([blank, comma, links, right], this)
end;

function accept (this: idea): idea;
begin
 accept := belong ([blank, comma, enter], this)
end;

function accede (this: idea): idea;
begin
 accede := belong ([blank, enter], this)
end;

function critic (this: idea): idea;
begin
 critic := belong ([comma, point], this)
end;

function advice (this: idea): idea;
begin
 advice := critic (class (this))
end;

function kind (term: info): mode;
begin
 if term = 'log' then kind := null else kind := moot
end;

function render (this: idea): idea;
begin
 render := this;
 if this = nil then this := quash (this)
end;

function permit (line: info;
                 this: idea): idea;
var here: idea;
begin
 here :=
  vid (pass (con, links + elide,
  dim (pass (con, links + blank + line + blank, lash (nil)))));
 repeat here := tip until advice (here) <> nil;
 here := render (accept (clash (con, here)));
 permit := here
end;

function prompt (line: info): idea;
begin
 prompt := permit (line, nil)
end;

function recycle (this: idea): idea;
var here: idea;

function deposit (this: idea): idea;
var here: idea;
begin
 here := nil;
 if this <> nil then with this^ do
  begin
   here := by;
   if sign = links then on := recycle (on);
   dispose (this)
  end;
 deposit := here
end;

begin { recycle }
 here := nil;
 if this <> nil then with this^ do
  begin
   here := by;
   if here <> nil then
    begin
     by := nil;
     repeat here := deposit (here)
      until here = nil
    end
  end;
 recycle := here
end;

function repose (that, this: idea): idea;
begin
 repose := revert (recycle (that), this)
end;

function critique (term: info;
                   this: idea): idea;
begin
 if term = 'lex' then writeln ('<* no direction home; please reset *>')
 else
 if term = 'lit' then
  write ('<* unknown word beginning with "', arch (this), '" *>')
 else
 if term = 'par' then write ('<* wrong parens *>');
 critique := just (turn (hold (this)))
end;

o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o~~~~~~~~~o