2 people like it.

Mini SNOBOL Interpreter

Minimal SNOBOL abstract syntax tree (AST), interpreter and internal DSL (but no parser), just enough to run some simple samples from Wikipedia's SNOBOL page: http://en.wikipedia.org/wiki/SNOBOL and most of the pattern matching examples from the SNOBOL 4 Tutorial http://www.snobol4.org/docs/burks/tutorial/ch4.htm

Abstract Syntax Tree

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
type label = string
type name = string
type arithmetic = Add | Subtract | Multiply | Divide | Power
type value = 
   | String of string 
   | Integer of int
   | Pattern of pattern
and expression = 
   | Value of value
   | Variable of name
   | Arithmetic of expression * arithmetic * expression
and pattern =
   | Expression of expression
   | And of pattern list
   | Or of pattern list
   | ConditionalAssignment of pattern * name
   | Invoke of name * expression list   
type transferOn = Success | Failure | Goto
type transfer = { On:transferOn; Goto:label }
type command =
   | Assign of name * expression list
   | Match of expression list * pattern  
   | Replace of name * pattern * expression list
   | Unit
type line = {
    Label : label option
    Command : command
    Transfer : transfer option
    }

Environment

1: 
2: 
3: 
4: 
5: 
6: 
type environment = {
   Subject:string;   
   Cursor:int;
   Actions:(unit->unit) list
   Result:value;
   Success:bool }

Conversion Functions

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
let (|AsInt|_|) s =
   match System.Int32.TryParse(s) with
   | true, n -> Some n
   | false, _ -> None
let toString = function 
   | String s -> s 
   | Integer n -> n.ToString()
   | Pattern _ -> invalidOp ""
let (|ToString|_|) = function
   | String s -> Some s 
   | Integer n -> Some (n.ToString())
   | Pattern _ -> None
let toInt = function
   | Integer n -> n
   | String(AsInt n) -> n
   | _ -> invalidOp ""
let (|ToInt|_|) = function
   | Integer n -> Some n
   | String(AsInt n) -> Some n
   | _ -> None

Built-in Functions

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
/// Match remainder of subject
let rem env =
   let result = env.Subject.Substring(env.Cursor)
   seq [{ env with Result=String result; Cursor=env.Subject.Length-1 }]
///  Match arbitrary characters
let arb env =
   seq {
      for n in 0..env.Subject.Length-env.Cursor ->                    
         let result = env.Subject.Substring(env.Cursor,n)
         {env with Cursor=env.Cursor+n; Result=String result }
   }
/// Match fixed-length string
let len env n =
   if n > env.Subject.Length + env.Cursor then 
      seq [{ env with Success=false }]
   else
      let result = env.Subject.Substring(env.Cursor,n)
      seq [{ env with Cursor=env.Cursor+n; Result=String result }]
/// Verify cursor position
let pos env n =
   if n = env.Cursor then seq [env]
   else seq [{ env with Success=false }]
let rpos env n =
   if n = env.Subject.Length - env.Cursor then seq [env]
   else seq [{ env with Success=false }]
/// Match to fixed position
let tab env n =
   if n >= env.Cursor && n < env.Subject.Length then
      let result = env.Subject.Substring(env.Cursor, n - env.Cursor)
      seq [{env with Result=String result; Cursor=n }]
   else seq [{ env with Success=false }]
let rtab env n =
   if (env.Subject.Length - env.Cursor) >= n then
      let length = env.Subject.Length - env.Cursor - n
      let result = env.Subject.Substring(env.Cursor, length)
      seq [{env with Result=String result; Cursor=env.Subject.Length-n }]
   else seq [{ env with Success=false }]
/// Match one character
let any env (s:string) =  
   let c = env.Subject.Chars(env.Cursor)   
   if s |> String.exists ((=)c) then
      seq [{ env with Cursor=env.Cursor+1; Result=String(c.ToString()) }]
   else
      seq [{ env with Success=false }]
let notany env (s:string) =
   let c = env.Subject.Chars(env.Cursor)   
   if not(s |> String.exists ((=)c)) then
      seq [{ env with Cursor=env.Cursor+1; Result=String(c.ToString()) }]
   else
      seq [{ env with Success=false }]
/// Match a run of characters
let span env (s:string) =    
   let mutable n = 0  
   while env.Cursor+n < env.Subject.Length &&  
         let c = env.Subject.Chars(env.Cursor+n) in
         (s |> String.exists ((=)(c))) do n <- n + 1
   if n > 0 
   then
      let result = env.Subject.Substring(env.Cursor,n)
      seq [{ env with Cursor=env.Cursor+n; Result=String result }]
   else seq [{ env with Success=false }]
let ``break`` env s =   
   let mutable n = 0
   while env.Cursor+n < env.Subject.Length &&
         let c = env.Subject.Chars(env.Cursor+n) in 
         (s |> String.exists ((=)(c)) |> not) do n <- n + 1
   let result = env.Subject.Substring(env.Cursor,n)
   seq [{ env with Cursor=env.Cursor+n; Result=String result }]
// Invoke a built-in function
let invoke env name args =
   match name, args with
   | "REM", [] -> rem env 
   | "ARB", [] -> arb env
   | "LEN", [ToInt n] -> len env n
   | "POS", [ToInt n] -> pos env n
   | "RPOS", [ToInt n] -> rpos env n
   | "TAB", [ToInt n] -> tab env n
   | "RTAB", [ToInt n] -> rtab env n
   | "ANY", [ToString s] -> any env s
   | "NOTANY", [ToString s] -> notany env s
   | "SPAN", [ToString s] -> span env s
   | "BREAK", [ToString s] -> ``break`` env s
   | _ -> failwith "Not supported"

Interpereter

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
let run input output (lines:line list) =
   let variables = System.Collections.Generic.Dictionary<name, value>()
   let assign name value =
      match name, value with
      | "OUTPUT", Pattern(_) -> name |> output
      | "OUTPUT", _ -> value |> toString |> output
      | _, _ -> variables.[name] <- value
   let get name =
      match name with
      | "INPUT" -> input () |> String
      | _ -> variables.[name]
   let rec concat expressions =      
      System.String.Concat [for e in expressions -> evaluate e |> toString] |> String
   and evaluate expression =      
      match expression with
      | Value(value) -> value
      | Variable(name) -> get name
      | Arithmetic(lhs,op,rhs) ->
         match evaluate lhs, evaluate rhs with
         | Integer l, Integer r -> Integer(arithmetic op l r)
         | Integer l, String (AsInt r) -> Integer(arithmetic op l r)
         | _ -> invalidOp "Illegal data type"
   and arithmetic op l r =
      match op with
      | Add -> l + r
      | Subtract -> l - r
      | Multiply -> l * r
      | Divide -> l / r
      | Power -> pown l r
   and tryPattern (env:environment) pattern : environment seq =
      match pattern with
      | Expression(expression) ->
         let subject = env.Subject.Substring(env.Cursor)
         let value = evaluate expression
         match value with
         | Pattern pattern -> tryPattern env pattern
         | value ->  
            let value = value |> toString
            if subject.StartsWith(value)
            then
               let cursor = env.Cursor+value.Length
               let result = String value
               seq [{ env with Cursor=cursor; Result=result }]
            else 
               seq [{ env with Success = false }]
      | And(patterns) ->
         let rec applyPattern env = function
            | [] -> env
            | p::ps ->
               let newEnvs = tryPattern env p       
               let found =
                  newEnvs |> Seq.tryPick (fun newEnv ->
                     if newEnv.Success then                        
                        let env = applyPattern newEnv ps
                        if env.Success
                        then Some env
                        else None
                     else None
                  )
               match found with
               | Some newEnv -> 
                  let result = toString env.Result + toString newEnv.Result
                  { newEnv with Result = String result }
               | None -> {env with Success=false}
         seq [applyPattern env patterns]
      | Or(patterns) -> 
         let rec findPattern = function
            | [] -> seq [{ env with Success = false }]
            | p::ps ->
               let newEnvs = tryPattern env p
               match newEnvs |> Seq.tryFind (fun env -> env.Success) with
               | Some env -> seq [env] 
               | None -> findPattern ps
         findPattern patterns
      | ConditionalAssignment(pattern,subject) ->
         let envs = tryPattern env pattern
         seq {
            for env in envs -> 
               let onSuccess () = assign subject env.Result
               { env with Actions=onSuccess::env.Actions }
         }
      | Invoke(name, args) ->
         invoke env name [for arg in args -> evaluate arg]
   let patternMatch subject pattern =      
      let env = { Subject=subject; Cursor=0; Result=String ""; Actions=[]; Success=true}
      let rec tryFromIndex n =
         if n = subject.Length then { env with Success=false }
         else
            let env = { env with Cursor=n }            
            let found = tryPattern env pattern |> Seq.tryFind (fun env -> env.Success)
            match found with
            | None -> tryFromIndex (n+1)
            | Some newEnv ->
               for action in newEnv.Actions |> List.rev do action()
               { newEnv with Cursor = env.Cursor }
      tryFromIndex 0
   let rec gotoLine i =
      let line = lines.[i]      
      let success =
         match line.Command with           
         | Assign(subject, expressions) ->             
            let value = 
               match expressions with
               | expression::[] -> evaluate expression
               | _ -> concat expressions
            assign subject value
            true
         | Match(subject, pattern) ->
            let subject = concat subject |> toString                       
            let env = patternMatch subject pattern
            env.Success
         | Replace(name, pattern, expressions) ->
            let subject = variables.[name] |> toString
            let env = patternMatch subject pattern
            if env.Success then
               let subject = subject.Remove(env.Cursor, (env.Result |> toString).Length)
               let subject = subject.Insert(env.Cursor, concat expressions |> toString)
               variables.[name] <- String subject
            env.Success
         | Unit -> true
      match line.Transfer with
      | None -> 
         if i < lines.Length-1 then gotoLine (i+1)
      | Some(transfer) ->
         let j = 
            lines 
            |> List.findIndex (fun line -> 
                  match line.Label with 
                  | Some label -> label = transfer.Goto 
                  | None -> false)                        
         match transfer.On, success with
         | Success, true -> gotoLine j
         | Failure, false -> gotoLine j
         | Goto, _ -> gotoLine j
         | _ when i < lines.Length-1 -> gotoLine (i+1)
         | _ -> ()         
   gotoLine 0

Internal DSL

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
let S s = Value(String s)
let I s = Value(Integer s)
let V s = Variable(s)
let E e = Expression(e)
let P e = Value(Pattern(e))
let (.+) lhs rhs = Arithmetic(lhs,Add,rhs)
let (=.) name expressions = Assign(name,expressions)
let (.=) pattern name = ConditionalAssignment(pattern,name)
let (=?) subject pattern = Match([subject], pattern)
let (/=) pattern expressions = (pattern,expressions)
let (=/) (name) (pattern,expressions) = Replace(name,pattern,expressions)
let ARB = Invoke("ARB",[])
let REM = Invoke("REM",[])
let LEN(e) = Invoke("LEN",[e])
let POS(e) = Invoke("POS",[e])
let RPOS(e) = Invoke("RPOS",[e])
let TAB(e) = Invoke("TAB",[e])
let RTAB(e) = Invoke("RTAB",[e])
let ANY(e) = Invoke("ANY",[e])
let NOTANY(e) = Invoke("NOTANY",[e])
let SPAN(e) = Invoke("SPAN",[e])
let BREAK(e) = Invoke("BREAK",[e])
type Line =
   static member Of(command,?label,?transfer) =
      {Command=command; Label=label; Transfer=transfer}

Hello World Example

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8: 
(*
          OUTPUT = "Hello world"
*)
let input () = ""
let output = printfn "%s"
[Line.Of( "OUTPUT" =. [S"Hello World"] )]
|> run input output
// > Hello World

Input Example

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
(*
          OUTPUT = "What is your name?"
          Username = INPUT
          OUTPUT = "Thank you, " Username
*)
[Line.Of( "OUTPUT" =. [S"What is your name?"])
 Line.Of( "Username" =. [V"INPUT"])
 Line.Of( "OUTPUT" =. [S"Thank you, "; V"Username"])]
|> run (fun () -> "Doctor") output
// > What is your name?
// > Thank you, Doctor

Control Flow Example

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
(*
          OUTPUT = "What is your name?"
          Username = INPUT
          Username "Jay"                                           :S(LOVE)
          Username "Kay"                                           :S(HATE)
MEH       OUTPUT = "Hi, " Username                                 :(END)
LOVE      OUTPUT = "How nice to meet you, " Username               :(END)
HATE      OUTPUT = "Oh. It's you, " Username
END
*)
let program =
   [
   Line.Of("OUTPUT" =. [S"What is your name?"])
   Line.Of("Username" =. [V"INPUT"])
   Line.Of(V"Username" =? E(S"J"), transfer={On=Success;Goto="LOVE"})
   Line.Of(V"Username" =? E(S"K"), transfer={On=Success;Goto="HATE"})
   Line.Of("OUTPUT" =. [S"Hi, ";V"Username"], label="MEH", 
      transfer={On=Goto;Goto="END"})
   Line.Of("OUTPUT" =. [S"How nice to meet you, "; V"Username"], label="LOVE", 
      transfer={On=Goto;Goto="END"})
   Line.Of("OUTPUT" =. [S"Oh. It's you, "; V"Username"], label="HATE")
   Line.Of(Unit, label="END")  
   ]
    
program |> run (fun () -> "Jay") output
// > What is your name?
// > How nice to meet you, Jay
program |> run (fun () -> "Kay") output
// > What is your name?
// > Oh. It's you, Kay
program |> run (fun () -> "Bob") output
// > What is your name?
// > Hi, Bob

Input Loop Example

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
(*
          OUTPUT = "This program will ask you for personal names"
          OUTPUT = "until you press return without giving it one"
          NameCount = 0                                            :(GETINPUT)
AGAIN     NameCount = NameCount + 1
          OUTPUT = "Name " NameCount ": " PersonalName
GETINPUT  OUTPUT = "Please give me name " NameCount + 1 
          PersonalName = INPUT
          PersonalName LEN(1)                                      :S(AGAIN)
          OUTPUT = "Finished. " NameCount " names requested."
END
*)

let loop =
   [
   Line.Of("OUTPUT" =. [S"This program will ask you for personal names"])
   Line.Of("OUTPUT" =. [S"until you press return without giving it one"])
   Line.Of("NameCount" =. [I 0], transfer={On=Goto;Goto="GETINPUT"})
   Line.Of("NameCount" =. [V"NameCount" .+ I 1], label="AGAIN")
   Line.Of("OUTPUT" =. [S"Name ";V"NameCount";S": ";V"PersonalName"])
   Line.Of("PersonalName" =. [V"INPUT"], label="GETINPUT")
   Line.Of(V"PersonalName" =? LEN(I 1), transfer={On=Success;Goto="AGAIN"})
   Line.Of("OUTPUT" =. [S"Finished. ";V"NameCount";S" names requested."] )
   ]

let names () =
   let names = seq ["Billy"; "Bob"; "Thornton"]
   let e = names.GetEnumerator()
   fun () -> if e.MoveNext() then e.Current else ""
loop |> run (names ()) output
// > This program will ask you for personal names
// > until you press return without giving it one
// > Name 1: Billy
// > Name 2: Bob
// > Name 3: Thornton
// > Finished. 3 names requested.

Simple Pattern Matching Examples

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
153: 
154: 
155: 
156: 
157: 
158: 
159: 
160: 
161: 
162: 
163: 
164: 
165: 
166: 
167: 
168: 
169: 
170: 
171: 
172: 
173: 
174: 
175: 
176: 
177: 
178: 
179: 
180: 
181: 
182: 
183: 
184: 
185: 
186: 
187: 
188: 
189: 
190: 
(*
          'BLUEBIRD' 'BIRD' . OUTPUT
END
*)
let bird = [Line.Of( S"BLUEBIRD" =? (E(S"BIRD") .= "OUTPUT") )]
bird |> run input output
// > BIRD

(*
          B = 'BLUEBIRD'
          B ('BLUE' | 'GOLD') . OUTPUT
          G = 'GOLDFISH'
          G ('BLUE' | 'GOLD') . OUTPUT
          COLOR = 'BLUE' | 'GOLD'
          B COLOR . OUTPUT
END
*)
let color =
   [
   // B = 'BLUEBIRD'
   Line.Of("B" =. [S"BLUEBIRD"])
   // B ('BLUE' | 'GOLD') . OUTPUT
   Line.Of(V"B" =? (Or [E(S"BLUE");E(S"GOLD")] .= "OUTPUT"))
   // G = 'GOLDFISH'
   Line.Of("G" =. [S"GOLDFISH"])
   // B ('BLUE' | 'GOLD') . OUTPUT
   Line.Of(V"G" =? (Or [E(S"BLUE");E(S"GOLD")] .= "OUTPUT"))
   // COLOR = 'BLUE' | 'GOLD'
   Line.Of("COLOR" =. [P(Or [E(S"GOLD");E(S"BLUE")])])
   // B COLOR . OUTPUT
   Line.Of(V"B" =? (E(V"COLOR") .= "OUTPUT"))
   ]
color |> run input output
// > BLUE
// > GOLD
// > BLUE

(*
          'B2' ('A' | 'B') . OUTPUT (1 | 2 | 3) . OUTPUT
*)
let b2 = 
   [
   Line.Of(S"B2" =? And [ Or [E(S"A");E(S"B")] .= "OUTPUT"
                          Or [E(S"1");E(S"2");E(S"3")] .= "OUTPUT"] )
   ]
b2 |> run input output
// > B
// > 2

(*
          'THE WINTER WINDS' 'WIN' REM . OUTPUT
*)
let winter = [Line.Of(S"THE WINTER WINDS" =? And[E(S"WIN"); REM .= "OUTPUT"])]
winter |> run input output
// > TER WINDS

(*
          'MOUNTAIN' 'O' ARB . OUTPUT 'A'
          'MOUNTAIN' 'O' ARB . OUTPUT 'U'
*)
let mountain =
   [Line.Of(S"MOUNTAIN" =? And[E(S"O");ARB .= "OUTPUT";E(S"A")])
    Line.Of(S"MOUNTAIN" =? And[E(S"O");ARB .= "OUTPUT";E(S"U")])]
mountain |> run input output
// > UNT
// >

(*
          S = 'ABCDA'
          S LEN(3) . OUTPUT RPOS(0)
          S POS(3) LEN(1) . OUTPUT
*)
let abcda =
   [
   Line.Of("S" =. [S"ABCDA"])
   Line.Of(V"S" =? And[LEN(I 3) .= "OUTPUT";RPOS(I 0)])
   Line.Of(V"S" =? And[POS(I 3);LEN(I 1) .= "OUTPUT"]) 
   ]
abcda |> run input output
// > CDA
// > D

(*
          'ABCDE' TAB(2) . OUTPUT RTAB(1) . OUTPUT REM . OUTPUT
*)
let abcde =
   [
   Line.Of(S"ABCDE" =? And [TAB(I 2) .= "OUTPUT"
                            RTAB(I 1) .= "OUTPUT"
                            REM .= "OUTPUT" ])
   ]
abcde |> run input output
// > AB
// > CD
// > E

(*
          VOWEL = ANY('AEIOU')          
          DVOWEL = VOWEL VOWEL
          NOTVOWEL = NOTANY('AEIOU')
          'VACUUM' VOWEL . OUTPUT
          'VACUUM' DVOWEL . OUTPUT
          'VACUUM' (VOWEL NOTVOWEL) . OUTPUT
*)
let vacuum =
   [
   Line.Of("VOWEL" =. [P(ANY(S"AEIOU"))])
   Line.Of("DVOWEL" =. [P(And[E(V"VOWEL");E(V"VOWEL")])])
   Line.Of("NOTVOWEL" =. [P(NOTANY(S"AEIOU"))])
   Line.Of(S"VACUUM" =? (E(V"VOWEL") .= "OUTPUT"))
   Line.Of(S"VACUUM" =? (E(V"DVOWEL") .= "OUTPUT"))
   Line.Of(S"VACUUM" =? (And [E(V"VOWEL");E(V"NOTVOWEL")] .= "OUTPUT"))
   ]
vacuum |> run input output
// > A
// > UU
// > AC

(*
          LETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ'-"
          WORD = SPAN(LETTERS)
          'SAMPLE LINE' WORD . OUTPUT
          GAP = BREAK(LETTERS)
          GAPO = GAP . OUTPUT
          WORDO = WORD . OUTPUT
          ': ONE, TWO, THREE' GAPO WORDO GAPO WORDO
*)

let word =
   [
   Line.Of("LETTERS" =. [S"ABCDEFGHIJKLMNOPQRSTUVWXYZ'-"])
   Line.Of(S"SAMPLE LINE" =? (SPAN(V"LETTERS") .= "OUTPUT"))
   Line.Of("WORD" =. [P(SPAN(V"LETTERS"))])  
   Line.Of("GAP" =. [P(BREAK(V"LETTERS"))])  
   Line.Of("GAPO" =. [P(E(V("GAP")) .= "OUTPUT")])
   Line.Of("WORDO" =. [P(E(V("WORD")) .= "OUTPUT")])   
   Line.Of(S": ONE, TWO, THREE" =? And [E(V"GAPO");E(V"WORDO");E(V"GAPO");E(V"WORDO")])
   ]

word |> run input output
// > SAMPLE
// > : 
// > ONE
// > , 
// > TWO

(*
          T = "MASH"
          T 'M' = 'B'
          OUTPUT = T
*)

let mash =
   [
   Line.Of("T" =. [S"MASH"])
   Line.Of("T" =/ (E(S"M") /= [S"B"]))
   Line.Of("OUTPUT" =. [V"T"])
   ]

mash |> run input output
// > BASH

(*
          T = 'MUCH ADO ABOUT NOTHING'
          T 'ADO' = 'FUSS'
          OUTPUT = T
          T 'NOTHING' =
          OUTPUT = T
          VOWEL = ANY('AEIOU')
 VL       T VOWEL = '*'          :S(VL)        
          OUTPUT = T
*)

let much =
   [
   Line.Of("T" =. [S"MUCH ADO ABOUT NOTHING"])
   Line.Of("T" =/ (E(S("ADO")) /= [S"FUSS"]))
   Line.Of("OUTPUT" =. [V("T")])
   Line.Of("T" =/ (E(S("NOTHING")) /= [S""]))
   Line.Of("OUTPUT" =. [V("T")])
   Line.Of("VOWEL" =. [P(ANY(S"AIEOU"))])
   Line.Of("T" =/ (E(V"VOWEL") /= [S"*"]), label="VL", 
      transfer={On=Success;Goto="VL"})
   Line.Of("OUTPUT" =. [V("T")])
   ]

much |> run input output
// > MUCH FUSS ABOUT NOTHING
// > MUCH FUSS ABOUT 
// > M*CH F*SS *B**T 
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
type name = string

Full name: Script.name
type arithmetic =
  | Add
  | Subtract
  | Multiply
  | Divide
  | Power

Full name: Script.arithmetic
union case arithmetic.Add: arithmetic
union case arithmetic.Subtract: arithmetic
union case arithmetic.Multiply: arithmetic
union case arithmetic.Divide: arithmetic
union case arithmetic.Power: arithmetic
type value =
  | String of string
  | Integer of int
  | Pattern of pattern

Full name: Script.value
Multiple items
union case value.String: string -> value

--------------------
module String

from Microsoft.FSharp.Core
union case value.Integer: int -> value
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
union case value.Pattern: pattern -> value
type pattern =
  | Expression of expression
  | And of pattern list
  | Or of pattern list
  | ConditionalAssignment of pattern * name
  | Invoke of name * expression list

Full name: Script.pattern
type expression =
  | Value of value
  | Variable of name
  | Arithmetic of expression * arithmetic * expression

Full name: Script.expression
union case expression.Value: value -> expression
union case expression.Variable: name -> expression
union case expression.Arithmetic: expression * arithmetic * expression -> expression
union case pattern.Expression: expression -> pattern
union case pattern.And: pattern list -> pattern
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
union case pattern.Or: pattern list -> pattern
union case pattern.ConditionalAssignment: pattern * name -> pattern
union case pattern.Invoke: name * expression list -> pattern
type transferOn =
  | Success
  | Failure
  | Goto

Full name: Script.transferOn
union case transferOn.Success: transferOn
Multiple items
union case transferOn.Failure: transferOn

--------------------
active recognizer Failure: exn -> string option

Full name: Microsoft.FSharp.Core.Operators.( |Failure|_| )
union case transferOn.Goto: transferOn
type transfer =
  {On: transferOn;
   Goto: label;}

Full name: Script.transfer
transfer.On: transferOn
transfer.Goto: label
type label = string

Full name: Script.label
type command =
  | Assign of name * expression list
  | Match of expression list * pattern
  | Replace of name * pattern * expression list
  | Unit

Full name: Script.command
union case command.Assign: name * expression list -> command
union case command.Match: expression list * pattern -> command
union case command.Replace: name * pattern * expression list -> command
union case command.Unit: command
type line =
  {Label: label option;
   Command: command;
   Transfer: transfer option;}

Full name: Script.line
line.Label: label option
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
line.Command: command
line.Transfer: transfer option
type environment =
  {Subject: string;
   Cursor: int;
   Actions: (unit -> unit) list;
   Result: value;
   Success: bool;}

Full name: Script.environment
environment.Subject: string
environment.Cursor: int
environment.Actions: (unit -> unit) list
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
environment.Result: value
environment.Success: bool
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val s : string
namespace System
type Int32 =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MaxValue : int
    static val MinValue : int
    static member Parse : s:string -> int + 3 overloads
    static member TryParse : s:string * result:int -> bool + 1 overload
  end

Full name: System.Int32
System.Int32.TryParse(s: string, result: byref<int>) : bool
System.Int32.TryParse(s: string, style: System.Globalization.NumberStyles, provider: System.IFormatProvider, result: byref<int>) : bool
val n : int
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val toString : _arg1:value -> string

Full name: Script.toString
System.Int32.ToString() : string
System.Int32.ToString(provider: System.IFormatProvider) : string
System.Int32.ToString(format: string) : string
System.Int32.ToString(format: string, provider: System.IFormatProvider) : string
val invalidOp : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidOp
val toInt : _arg1:value -> int

Full name: Script.toInt
active recognizer AsInt: string -> int option

Full name: Script.( |AsInt|_| )
val rem : env:environment -> seq<environment>

Full name: Script.rem


 Match remainder of subject
val env : environment
val result : string
System.String.Substring(startIndex: int) : string
System.String.Substring(startIndex: int, length: int) : string
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
property System.String.Length: int
val arb : env:environment -> seq<environment>

Full name: Script.arb


  Match arbitrary characters
val len : env:environment -> n:int -> seq<environment>

Full name: Script.len


 Match fixed-length string
val pos : env:environment -> n:int -> seq<environment>

Full name: Script.pos


 Verify cursor position
val rpos : env:environment -> n:int -> seq<environment>

Full name: Script.rpos
val tab : env:environment -> n:int -> seq<environment>

Full name: Script.tab


 Match to fixed position
val rtab : env:environment -> n:int -> seq<environment>

Full name: Script.rtab
val length : int
val any : env:environment -> s:string -> seq<environment>

Full name: Script.any


 Match one character
val c : char
property System.String.Chars: int -> char
val exists : predicate:(char -> bool) -> str:string -> bool

Full name: Microsoft.FSharp.Core.String.exists
System.Char.ToString() : string
System.Char.ToString(provider: System.IFormatProvider) : string
val notany : env:environment -> s:string -> seq<environment>

Full name: Script.notany
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val span : env:environment -> s:string -> seq<environment>

Full name: Script.span


 Match a run of characters
val mutable n : int
val invoke : env:environment -> name:string -> args:value list -> seq<environment>

Full name: Script.invoke
Multiple items
val name : string

--------------------
type name = string

Full name: Script.name
val args : value list
active recognizer ToInt: value -> int option

Full name: Script.( |ToInt|_| )
active recognizer ToString: value -> string option

Full name: Script.( |ToString|_| )
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val run : input:(unit -> string) -> output:(string -> unit) -> lines:line list -> unit

Full name: Script.run
val input : (unit -> string)
val output : (string -> unit)
val lines : line list
val variables : System.Collections.Generic.Dictionary<name,value>
namespace System.Collections
namespace System.Collections.Generic
Multiple items
type Dictionary<'TKey,'TValue> =
  new : unit -> Dictionary<'TKey, 'TValue> + 5 overloads
  member Add : key:'TKey * value:'TValue -> unit
  member Clear : unit -> unit
  member Comparer : IEqualityComparer<'TKey>
  member ContainsKey : key:'TKey -> bool
  member ContainsValue : value:'TValue -> bool
  member Count : int
  member GetEnumerator : unit -> Enumerator<'TKey, 'TValue>
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member Item : 'TKey -> 'TValue with get, set
  ...
  nested type Enumerator
  nested type KeyCollection
  nested type ValueCollection

Full name: System.Collections.Generic.Dictionary<_,_>

--------------------
System.Collections.Generic.Dictionary() : unit
System.Collections.Generic.Dictionary(capacity: int) : unit
System.Collections.Generic.Dictionary(comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>) : unit
System.Collections.Generic.Dictionary(capacity: int, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
val assign : (string -> value -> unit)
Multiple items
val value : value

--------------------
type value =
  | String of string
  | Integer of int
  | Pattern of pattern

Full name: Script.value
val get : (string -> value)
val concat : (seq<expression> -> value)
val expressions : seq<expression>
Multiple items
type String =
  new : value:char -> string + 7 overloads
  member Chars : int -> char
  member Clone : unit -> obj
  member CompareTo : value:obj -> int + 1 overload
  member Contains : value:string -> bool
  member CopyTo : sourceIndex:int * destination:char[] * destinationIndex:int * count:int -> unit
  member EndsWith : value:string -> bool + 2 overloads
  member Equals : obj:obj -> bool + 2 overloads
  member GetEnumerator : unit -> CharEnumerator
  member GetHashCode : unit -> int
  ...

Full name: System.String

--------------------
System.String(value: nativeptr<char>) : unit
System.String(value: nativeptr<sbyte>) : unit
System.String(value: char []) : unit
System.String(c: char, count: int) : unit
System.String(value: nativeptr<char>, startIndex: int, length: int) : unit
System.String(value: nativeptr<sbyte>, startIndex: int, length: int) : unit
System.String(value: char [], startIndex: int, length: int) : unit
System.String(value: nativeptr<sbyte>, startIndex: int, length: int, enc: System.Text.Encoding) : unit
System.String.Concat([<System.ParamArray>] values: string []) : string
   (+0 other overloads)
System.String.Concat(values: System.Collections.Generic.IEnumerable<string>) : string
   (+0 other overloads)
System.String.Concat<'T>(values: System.Collections.Generic.IEnumerable<'T>) : string
   (+0 other overloads)
System.String.Concat([<System.ParamArray>] args: obj []) : string
   (+0 other overloads)
System.String.Concat(arg0: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string) : string
   (+0 other overloads)
System.String.Concat(arg0: obj, arg1: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string, str2: string) : string
   (+0 other overloads)
System.String.Concat(arg0: obj, arg1: obj, arg2: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string, str2: string, str3: string) : string
   (+0 other overloads)
val e : expression
val evaluate : (expression -> value)
Multiple items
val expression : expression

--------------------
type expression =
  | Value of value
  | Variable of name
  | Arithmetic of expression * arithmetic * expression

Full name: Script.expression
Multiple items
val name : name

--------------------
type name = string

Full name: Script.name
val lhs : expression
val op : arithmetic
val rhs : expression
val l : int
val r : int
Multiple items
val arithmetic : (arithmetic -> int -> int -> int)

--------------------
type arithmetic =
  | Add
  | Subtract
  | Multiply
  | Divide
  | Power

Full name: Script.arithmetic
val pown : x:'T -> n:int -> 'T (requires member get_One and member ( * ) and member ( / ))

Full name: Microsoft.FSharp.Core.Operators.pown
val tryPattern : (environment -> pattern -> seq<environment>)
Multiple items
val pattern : pattern

--------------------
type pattern =
  | Expression of expression
  | And of pattern list
  | Or of pattern list
  | ConditionalAssignment of pattern * name
  | Invoke of name * expression list

Full name: Script.pattern
val subject : string
Multiple items
val value : string

--------------------
type value =
  | String of string
  | Integer of int
  | Pattern of pattern

Full name: Script.value
System.String.StartsWith(value: string) : bool
System.String.StartsWith(value: string, comparisonType: System.StringComparison) : bool
System.String.StartsWith(value: string, ignoreCase: bool, culture: System.Globalization.CultureInfo) : bool
val cursor : int
val result : value
val patterns : pattern list
val applyPattern : (environment -> pattern list -> environment)
val p : pattern
val ps : pattern list
val newEnvs : seq<environment>
val found : environment option
module Seq

from Microsoft.FSharp.Collections
val tryPick : chooser:('T -> 'U option) -> source:seq<'T> -> 'U option

Full name: Microsoft.FSharp.Collections.Seq.tryPick
val newEnv : environment
val findPattern : (pattern list -> seq<environment>)
val tryFind : predicate:('T -> bool) -> source:seq<'T> -> 'T option

Full name: Microsoft.FSharp.Collections.Seq.tryFind
val subject : name
val envs : seq<environment>
val onSuccess : (unit -> unit)
val args : expression list
val arg : expression
val patternMatch : (string -> pattern -> environment)
val tryFromIndex : (int -> environment)
val action : (unit -> unit)
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val gotoLine : (int -> unit)
val i : int
Multiple items
val line : line

--------------------
type line =
  {Label: label option;
   Command: command;
   Transfer: transfer option;}

Full name: Script.line
val success : bool
val expressions : expression list
val subject : expression list
System.String.Remove(startIndex: int) : string
System.String.Remove(startIndex: int, count: int) : string
System.String.Insert(startIndex: int, value: string) : string
property List.Length: int
Multiple items
val transfer : transfer

--------------------
type transfer =
  {On: transferOn;
   Goto: label;}

Full name: Script.transfer
val j : int
val findIndex : predicate:('T -> bool) -> list:'T list -> int

Full name: Microsoft.FSharp.Collections.List.findIndex
Multiple items
val label : label

--------------------
type label = string

Full name: Script.label
union case transferOn.Failure: transferOn
val S : s:string -> expression

Full name: Script.S
val I : s:int -> expression

Full name: Script.I
val s : int
val V : s:name -> expression

Full name: Script.V
val s : name
val E : e:expression -> pattern

Full name: Script.E
val P : e:pattern -> expression

Full name: Script.P
val e : pattern
val subject : expression
Multiple items
val pattern : 'a

--------------------
type pattern =
  | Expression of expression
  | And of pattern list
  | Or of pattern list
  | ConditionalAssignment of pattern * name
  | Invoke of name * expression list

Full name: Script.pattern
val expressions : 'b
val ARB : pattern

Full name: Script.ARB
val REM : pattern

Full name: Script.REM
val LEN : e:expression -> pattern

Full name: Script.LEN
val POS : e:expression -> pattern

Full name: Script.POS
val RPOS : e:expression -> pattern

Full name: Script.RPOS
val TAB : e:expression -> pattern

Full name: Script.TAB
val RTAB : e:expression -> pattern

Full name: Script.RTAB
val ANY : e:expression -> pattern

Full name: Script.ANY
val NOTANY : e:expression -> pattern

Full name: Script.NOTANY
val SPAN : e:expression -> pattern

Full name: Script.SPAN
val BREAK : e:expression -> pattern

Full name: Script.BREAK
type Line =
  static member Of : command:command * ?label:label * ?transfer:transfer -> line

Full name: Script.Line
static member Line.Of : command:command * ?label:label * ?transfer:transfer -> line

Full name: Script.Line.Of
Multiple items
val command : command

--------------------
type command =
  | Assign of name * expression list
  | Match of expression list * pattern
  | Replace of name * pattern * expression list
  | Unit

Full name: Script.command
Multiple items
val label : label option

--------------------
type label = string

Full name: Script.label
Multiple items
val transfer : transfer option

--------------------
type transfer =
  {On: transferOn;
   Goto: label;}

Full name: Script.transfer
val input : unit -> string

Full name: Script.input
val output : (string -> unit)

Full name: Script.output
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
static member Line.Of : command:command * ?label:label * ?transfer:transfer -> line
val program : line list

Full name: Script.program
val loop : line list

Full name: Script.loop
val names : unit -> (unit -> string)

Full name: Script.names
val names : seq<string>
val e : System.Collections.Generic.IEnumerator<string>
System.Collections.Generic.IEnumerable.GetEnumerator() : System.Collections.Generic.IEnumerator<string>
System.Collections.IEnumerator.MoveNext() : bool
property System.Collections.Generic.IEnumerator.Current: string
val bird : line list

Full name: Script.bird
val color : line list

Full name: Script.color
val b2 : line list

Full name: Script.b2
val winter : line list

Full name: Script.winter
val mountain : line list

Full name: Script.mountain
val abcda : line list

Full name: Script.abcda
val abcde : line list

Full name: Script.abcde
val vacuum : line list

Full name: Script.vacuum
val word : line list

Full name: Script.word
val mash : line list

Full name: Script.mash
val much : line list

Full name: Script.much

More information

Link:http://fssnip.net/oV
Posted:10 years ago
Author:Phillip Trelford
Tags: snobol , language , ast , interpreter