124 | endif
125 |
126 | HiLink braidNumber Number
127 | HiLink braidBlock Block
128 | HiLink braidRegion Region
129 | HiLink braidException Exception
130 | HiLink braidConstant Constant
131 | HiLink braidString String
132 | HiLink braidEscape SpecialChar
133 | HiLink braidInterpolationDelimiter Delimiter
134 | HiLink braidConditional Conditional
135 | HiLink braidFunctionDeclaration Function
136 | HiLink braidFunctionInvocation Function
137 | HiLink braidVariable Identifier
138 | HiLink braidBoolean Boolean
139 | HiLink braidConstant Constant
140 | HiLink braidBuiltIn StorageClass
141 | HiLink braidType Type
142 | HiLink braidComment Comment
143 | HiLink braidCommentTodo Todo
144 | HiLink braidCommentDoc Tag
145 | HiLink braidCDocParam Todo
146 | HiLink braidOperator Operator
147 | HiLink braidRepeat Repeat
148 | HiLink braidRepeatAndCmdlet Repeat
149 | HiLink braidKeyword Keyword
150 | endif
151 |
152 | let b:current_syntax = "braid"
153 |
--------------------------------------------------------------------------------
/src/http.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; HTTP convenience functions
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | (using-assembly System.Net.Http)
8 |
9 | ;--------------------------------------------------------------------------
10 | ;
11 | (defn http/get
12 | "
13 | Download a web page as a text string, optionally specifying the headers to use.
14 | The default headers are {\"Accept\" \"*/*\" \"User-Agent\" \"curl/7.55.1\"}.
15 |
16 | Examples:
17 | (http/get \"http://wikipedia.org\") ; download main Wikipedia page
18 | (http/get -headers: { ... }] \"http://foo.org.org\") ; specify so headers for the download
19 | (http/get -verbose \"http://foo.org\") ; get verbose output
20 | (http/get -user \"foo:bar\" \"http://foo.org\") ; use basic auth for user 'foo'
21 |
22 | See also: http/getData http/getAsync http/getDataAsync http/post http/postAsync
23 | "
24 | [(^Uri? url) :headers: :verbose :user:]
25 |
26 | (const headers {"Accept" "*/*" "User-Agent" "curl/7.55.1" @headers})
27 |
28 | (when (some? user)
29 | (const user64 (.System.Text.Encoding/UTF8 | .GetBytes user | .Convert/ToBase64String))
30 | (!! headers "Authorization" "Basic ${user64}")
31 | )
32 |
33 | (let wc (new ^System.Net.WebClient))
34 | (foreach k:v headers
35 | (try
36 | (.headers wc | .add (tostring k) (tostring v))
37 | -catch: (fn e ->
38 | (throw "error processing header '${k}': ${(.message e)}")
39 | )
40 | )
41 | )
42 |
43 | (if Verbose
44 | (.headers wc | info)
45 | )
46 |
47 | (.downloadstring wc url)
48 | )
49 |
50 | ;--------------------------------------------------------------------------
51 | ;
52 | (defn http/getAsync
53 | "
54 | This function asynchronously downloads a web page as a text string. It returns
55 | a Task object. Use 'await' (Resolve) to get the results of this computation.
56 |
57 | You can optionally specifying the headers to use.
58 | The default headers are {\"Accept\" \"*/*\" \"User-Agent\" \"curl/7.55.1\"}.
59 |
60 | Examples:
61 | (http/getAsync \"http://wikipedia.org\" | await) ; download main Wikipedia page
62 | (http/getAsync -headers: { ... }] \"http://foo.org.org\") ; specify so headers for the download
63 | (http/getAsync -verbose \"http://foo.org\") ; get verbose output
64 | (http/getAsync -user \"foo:bar\" \"http://foo.org\") ; use basic auth for user 'foo'
65 |
66 | See also: http/get http/getAsync http/getDataAsync http/post http/postAsync
67 | "
68 | [(^Uri? url) :headers: :verbose :user:]
69 |
70 | (const headers {"Accept" "*/*" "User-Agent" "curl/7.55.1" @headers})
71 |
72 | (when (some? user)
73 | (const user64 (.System.Text.Encoding/UTF8 | .GetBytes user | .Convert/ToBase64String))
74 | (!! headers "Authorization" "Basic ${user64}")
75 | )
76 |
77 | (let wc (new ^System.Net.WebClient))
78 | (foreach k:v headers
79 | (try
80 | (.headers wc | .add (tostring k) (tostring v))
81 | -catch: (fn e ->
82 | (throw "error processing header '${k}': ${(.message e)}")
83 | )
84 | )
85 | )
86 |
87 | (if Verbose
88 | (.headers wc | info)
89 | )
90 |
91 | (.downloadstringTaskAsync wc url)
92 | )
93 |
94 | ;--------------------------------------------------------------------------
95 | ;
96 | (defn http/getData
97 | "
98 | Download a URL as a binary data.
99 |
100 | Examples:
101 | (http/getData imageURL | write-data 'image.png)
102 |
103 | See also: http/get http/getAsync http/getDataAsync http/post http/postAsync
104 | "
105 | [(^Uri? url)]
106 |
107 | (.downloaddata (new ^System.Net.WebClient) url)
108 | )
109 |
110 | ;--------------------------------------------------------------------------
111 | ;
112 | (defn http/getDataAsync
113 | "
114 | This function asynchronously downloads a web page as binary data. Once the
115 | download starts it will return a Task object. Pass this task object to 'await'
116 | to get the results of this computation.
117 |
118 | Examples:
119 | (http/getDataAsync imageURL | await | !! 0 | write-data 'image.png)
120 |
121 | See also: http/get http/getAsync http/getData http/post http/postAsync
122 | "
123 | [(^Uri? url)]
124 |
125 | (.downloaddataTaskAsync (new ^System.Net.WebClient) url)
126 | )
127 |
128 | ;--------------------------------------------------------------------------
129 | ;
130 | (defn http/post
131 | "
132 | This function posts a string to the specified URL. If the content argument is
133 | a string, it will be posted as is otherwise the cont will be encoded as JSON
134 | before posting it. By default, the function will return the response string however
135 | if '-eval' is specified, tge response will be parsed and evaluated as a braid script.
136 |
137 | Examples:
138 | (http/post \"http:/someurl.com\" {\"foo\" 123 \"bar\" 456})
139 |
140 | See also: http/get http/getAsync http/getData http/getDataAsync http/postAsync
141 | "
142 | [(^Uri? url) content :parse]
143 |
144 | (if (is? content ^string)
145 | (let content (new ^System.Net.Http.StringContent content))
146 | (let content (new ^System.Net.Http.StringContent (ToSourceString content)))
147 | )
148 |
149 | (let client (new ^System.Net.Http.HttpClient))
150 | (let response (await (.PostAsync client url content)))
151 | (let responseStr (response | .content | .ReadAsStringAsync | await))
152 | (if parse
153 | (parse-text responseStr | car | eval)
154 | resposeStr
155 | )
156 | )
157 |
158 | ;--------------------------------------------------------------------------
159 | ;
160 | (defn http/postAsync
161 | "
162 | This function asynchronously posts a string to the specified URL. If the content argument is
163 | a string, it will be posted as is otherwise the cont will be encoded as JSON
164 | before posting it. By default, the function will return tge response string however
165 | if '-eval' is specified, tge response will be parsed and evakuated as a braid script.
166 |
167 | See also: http/get http/getAsync http/getData http/getDataAsync http/post
168 | "
169 | [(^Uri? url) content]
170 |
171 | (if (is? content ^string)
172 | (let content (new ^System.Net.Http.StringContent content))
173 | (let content (new ^System.Net.Http.StringContent (ToSourceString content)))
174 | )
175 |
176 | (let client (new ^System.Net.Http.HttpClient))
177 | (.PostAsync client url content)
178 | )
179 |
180 |
--------------------------------------------------------------------------------
/src/graphics.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; A small set of utility functions for working with Windows Forms Graphics
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | ;
8 | ; Load the Windows Forms utilities
9 | ;
10 | (using-module winforms)
11 |
12 | (unless (bound? 'Graphics/Stack)
13 | (let Graphics/Stack (new ^System.Collections.Stack))
14 | )
15 |
16 | (let LastLastX 0)
17 | (let LastLastY 0)
18 | (let LastX 0)
19 | (let LastY 0)
20 |
21 | ;
22 | ; Function for creating the drawing pen
23 | ;
24 | (let DrawingPen null)
25 | (defn Graphics/SetPen
26 | "Set the default drawing pen."
27 | [(^int width) (^System.Drawing.Color? color)]
28 |
29 | (if DrawingPen (.Dispose DrawingPen))
30 | (def DrawingPen (new ^System.Drawing.Pen color))
31 | (.width DrawingPen Width)
32 | )
33 |
34 | ;
35 | ; Function for setting the drawing background color
36 | ;
37 | (let DrawingBrush null)
38 | (defn Graphics/SetBackgroundColor
39 | "Set the background color on the drawing surface."
40 | [(^System.Drawing.Color? color)]
41 |
42 | (def DrawingBrush (new ^System.Drawing.SolidBrush? color))
43 | (.fillRectangle graphics/formGraphics DrawingBrush rec)
44 | )
45 |
46 | ;
47 | ; Draw a line
48 | ;
49 | (let graphics/formGraphics null)
50 | (defn Graphics/DrawLine
51 | "Draw a line from [x1 y1] to [x2 y2]."
52 | [ x1 y1 x2 y2 ]
53 |
54 | (if (null? graphics/formGraphics)
55 | (throw "Graphics/DrawLine: graphics object is not initialized")
56 | )
57 | (.drawLine graphics/formGraphics DrawingPen (^int x1) (^int y1) (^int x2) (^int y2))
58 | (.System.Windows.Forms.Application/doEvents)
59 | (def LastLastX LastX)
60 | (def LastLastY LastY)
61 | (def LastX x2)
62 | (def LastY y2)
63 | )
64 |
65 | (defn Graphics/DrawTo
66 | "Draw starting from the last location."
67 | [x2 y2]
68 |
69 | (Graphics/DrawLine LastX LastY x2 y2)
70 | )
71 |
72 | (defn Graphics/MoveTo
73 | "Move the drawing pen to a new location."
74 | [x1 y1]
75 |
76 | (def LastX x1)
77 | (def LastY y1)
78 | )
79 |
80 | ;
81 | ; Variables used for the drawing surface
82 | ;
83 | (let DrawingSurface null)
84 | (let opacity 1.0)
85 | (let FormSize null)
86 | (let cx 0)
87 | (let cy 0)
88 | (let rec null)
89 | (let ^double LastAngle 0.0)
90 | (def Graphics/Stack (new ^System.Collections.Stack 0))
91 |
92 | (defn Graphics/CreateDrawingSurface
93 | "Function to create the drawing surface."
94 | [x y]
95 |
96 | ; Create the drawing surface form
97 | (def opacity 1.0)
98 | (def FormSize (wf/size x y))
99 | (def DrawingSurface (wf/form
100 | :Text "Drawing Surface -- Click the X to exit."
101 | :TopMost true
102 | :Opacity opacity
103 | :Size formSize
104 | :OnClick (fn o e -> (.close DrawingSurface))
105 | )
106 | )
107 |
108 | ; create the drawing surface with same size as the form
109 | (def cx (.ClientRectangle DrawingSurface | .Width))
110 | (def cy (.ClientRectangle DrawingSurface | .Height))
111 | (def rec (new ^System.Drawing.Rectangle 0 0 cx cy ))
112 | (def graphics/formGraphics (.CreateGraphics DrawingSurface))
113 | (def LastX 0)
114 | (def LastY 0)
115 | (def LastLastX 0)
116 | (def LastLastY 0)
117 | (def LastAngle 0.0)
118 | (if DrawingPen (.dispose DrawingPen))
119 | (def DrawingPen null)
120 | (if DrawingBrush (.dispose DrawingBrush))
121 | (def DrawingBrush null)
122 | (def Graphics/Stack (new ^System.Collections.Stack 0))
123 | )
124 |
125 | (defn Graphics/ShowDrawingSurface
126 | "Show the drawing surface."
127 | []
128 |
129 | (.ShowDialog DrawingSurface)
130 | (.dispose DrawingSurface)
131 | (def DrawingSurface null)
132 | (if DrawingPen (.dispose DrawingPen))
133 | (def DrawingPen null)
134 | (if DrawingBrush (.dispose DrawingBrush))
135 | (def DrawingBrush null)
136 | (def LastX 0)
137 | (def LastY 0)
138 | (def LastLastX 0)
139 | (def LastLastY 0)
140 | (def LastAngle 0.0)
141 | )
142 |
143 | (defn Graphics/SetDrawingScript
144 | "Set the script that will draw on the form."
145 | [drawingFunction]
146 |
147 | (if (null? drawingFunction)
148 | (throw "Graphics/SetDrawingScript: Drawing script was null")
149 | )
150 |
151 | (.add_Shown DrawingSurface
152 | (asEventHandler
153 | (lambda [o e]
154 | (graphics/SetBackgroundColor .system.drawing.color/black)
155 | (Graphics/SetPen 2 .drawing.color/white)
156 |
157 | ; call the closed-over script
158 | (drawingFunction)
159 | (.update DrawingSurface)
160 | )
161 | )
162 | )
163 | )
164 |
165 | (defn Graphics/DrawPicture
166 | "
167 | Show an x by y drawing surface and execute the argument function.
168 | "
169 | [x y drawingFunction]
170 |
171 | (Graphics/CreateDrawingSurface x y)
172 | (Graphics/SetDrawingScript drawingFunction)
173 | (graphics/ShowDrawingSurface)
174 | )
175 |
176 |
177 | ;-------------------------------------------------------------------
178 | ;
179 | ; Turtle graphics functions
180 | ;
181 |
182 | (unless (bound? 'graphics-conversion-factor)
183 | (const graphics-conversion-factor (2.0 | * .math/pi | / 360))
184 | )
185 |
186 | (defn graphics/PolarToCartesian
187 | "Utility to convert polar to cartesian coordinates."
188 | [angle length]
189 |
190 | (let angle (* angle graphics-conversion-factor))
191 | [
192 | (angle | .math/cos | * length | ^int?)
193 | (angle | .math/sin | * length | ^int?)
194 | ]
195 | )
196 |
197 | ;
198 | ; Save the turtle context as an vector of 3 elements on the stack
199 | ;
200 | (defn Graphics/PushContext []
201 | (.push Graphics/Stack [ LastX LastY LastAngle ])
202 | )
203 |
204 | ;
205 | ; Restore the saved turtle context
206 | ;
207 | (defn Graphics/PopContext []
208 | (let context (.pop Graphics/Stack))
209 | (def LastX:LastY:LastAngle: context)
210 | )
211 |
212 | ; Turn right (positive angle)
213 | ;
214 | (defn Graphics/Turtle-Right [degrees]
215 | (def LastAngle (LastAngle | + degrees | % 360 | ^double?))
216 | )
217 |
218 | ;
219 | ; Turn left (negative angle)
220 | ;
221 | (defn Graphics/Turtle-Left [degrees]
222 | (def LastAngle (LastAngle | - degrees | % 360 | ^double?))
223 | )
224 |
225 | ;
226 | ; Move forward drawing a line.
227 | ;
228 | (defn Graphics/Turtle-Forward [length]
229 | (let coordx:coordy: (graphics/PolarToCartesian LastAngle length))
230 | (Graphics/DrawTo (+ LastX coordX) (+ LastY coordy))
231 | )
232 |
233 |
--------------------------------------------------------------------------------
/Examples/turtle.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; Examples using the turtle from the graphics module
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | lambda []
8 |
9 | (using-module graphics)
10 |
11 | ;
12 | ; Draw a multi-colored square
13 | ;
14 | (defn drawturtlesquare []
15 | (Graphics/DrawPicture 600 500 (fn ->
16 | (Graphics/moveto 100 100)
17 | (Graphics/SetPen 3 (.system.drawing.color/Yellow))
18 | (Graphics/Turtle-Forward 300)
19 | (Graphics/Turtle-Right 90)
20 | (Graphics/SetPen 3 (.system.drawing.color/Green))
21 | (Graphics/Turtle-Forward 300)
22 | (Graphics/Turtle-Right 90)
23 | (Graphics/SetPen 3 (.system.drawing.color/Cyan))
24 | (Graphics/Turtle-Forward 300)
25 | (Graphics/Turtle-Right 90)
26 | (Graphics/SetPen 3 (.system.drawing.color/Red))
27 | (Graphics/Turtle-Forward 300)
28 | )
29 | )
30 | )
31 |
32 | ;
33 | ; Draw a turtle circle
34 | ;
35 | (defn drawCircle []
36 | (Graphics/DrawPicture 500 500 (fn ->
37 | (Graphics/moveto 250 100)
38 | (repeat 100
39 | (Graphics/Turtle-Forward 10)
40 | (Graphics/Turtle-Right 5)
41 | )
42 | )
43 | )
44 | )
45 |
46 | ;
47 | ; Rotating squares
48 | ;
49 | (defn rotating-squares []
50 | (Graphics/DrawPicture 500 500 (fn ->
51 | (Graphics/moveto 250 250)
52 |
53 | ; function to draw a square with sides
54 | (defn drawsquare [size]
55 | (repeat 3
56 | (Graphics/Turtle-Forward size)
57 | (Graphics/Turtle-Right 90))
58 | )
59 |
60 | (defn drawsquares [number_of_times size]
61 | (repeat number_of_times
62 | (drawsquare size) ; draw the square
63 | (incr size 3) ; make the size of :size 2 step bigger
64 | (Graphics/Turtle-Right 3) ; between each square
65 | )
66 | )
67 |
68 | (drawsquares 100 5)
69 | )
70 | )
71 | )
72 |
73 |
74 | ;
75 | ; Wheel of color
76 | ;
77 | (defn drawwheelOfColor []
78 | (Graphics/DrawPicture 600 600 (fn ->
79 | (foreach item [
80 | (.System.Drawing.Color/red)
81 | (.System.Drawing.Color/blue)
82 | (.System.Drawing.Color/yellow)
83 | (.System.Drawing.Color/green)
84 | ]
85 |
86 | (Graphics/SetPen 5 item)
87 | (foreach n (range 150)
88 | (Graphics/MoveTo 300 300)
89 | (Graphics/Turtle-Right 8)
90 | (Graphics/Turtle-Forward (* n 2))
91 | )
92 | )
93 | )
94 | )
95 | )
96 |
97 | ;
98 | ; Spiraling star
99 | ;
100 | (defn DrawSpiralingStar []
101 | (Graphics/DrawPicture 500 500 (fn ->
102 | (Graphics/moveto 250 250)
103 | (foreach item (range 40)
104 | (Graphics/Turtle-Forward (* item 10))
105 | (Graphics/Turtle-Right 144)
106 | )
107 | )
108 | )
109 | )
110 |
111 | ;
112 | ; Draw Serpienski's Gasket using the Turtle
113 | ;
114 | (defn drawgasket [n]
115 |
116 | (defn sierpinski
117 | | 0 _ ->
118 | | n length ->
119 | (repeat 3
120 | (Graphics/PushContext)
121 | (sierpinski (-- n) (/ length 2))
122 | (Graphics/PopContext)
123 | (Graphics/Turtle-Forward length)
124 | (Graphics/Turtle-Right 120)
125 | )
126 | )
127 |
128 | (Graphics/DrawPicture 500 500 (fn ->
129 | (Graphics/moveto 50 50)
130 | (Graphics/setpen 2 (.system.drawing.color/orange))
131 | (sierpinski n 400)
132 | )
133 | )
134 | )
135 |
136 | ;
137 | ; Draw the Snowflake Fractal
138 | ;
139 | (defn drawsnowflake []
140 | (Graphics/drawpicture 500 500 (fn ->
141 | (Graphics/setpen 2 (.system.drawing.color/lightblue))
142 | (Graphics/moveto 100 150)
143 |
144 | (defn snowflake_side [length depth]
145 | (if depth
146 | (do
147 | (decr depth)
148 | (let length (= length / 3))
149 | (snowflake_side length depth)
150 | (Graphics/Turtle-Left 60)
151 | (snowflake_side length depth)
152 | (Graphics/Turtle-Right 120)
153 | (snowflake_side length depth)
154 | (Graphics/Turtle-Left 60)
155 | (snowflake_side length depth)
156 | )
157 | (do
158 | (Graphics/Turtle-Forward length)
159 | )
160 | )
161 | )
162 |
163 | (defn snowflake [length depth]
164 | (repeat 4
165 | (snowflake_side length depth)
166 | (Graphics/Turtle-Right 120)
167 | )
168 | )
169 |
170 | (snowflake 300 4)
171 | )
172 | )
173 | )
174 |
175 | ;
176 | ; Draw a fractal tree using the Turtle
177 | ;
178 | (defn drawfractal []
179 | (Graphics/drawpicture 600 600
180 | (fn ->
181 | (defn tree [len angle st]
182 | (if (>= len st)
183 | (do
184 | (Graphics/PushContext)
185 | (let len (= len / 2))
186 | (Graphics/Turtle-Forward len)
187 | (Graphics/Turtle-Left angle)
188 | (tree len angle st)
189 | (Graphics/Turtle-Right angle)
190 | (tree len angle st)
191 | (Graphics/Turtle-Right angle)
192 | (tree len angle st)
193 | (Graphics/Turtle-Left angle)
194 | ; Restore the previous position; equivalent of back...
195 | (Graphics/PopContext)
196 | )
197 | )
198 | )
199 |
200 | (Graphics/SetBackgroundColor (.System.Drawing.Color/black))
201 | (Graphics/MoveTo 0 300)
202 | (Graphics/SetPen 1 (.system.drawing.color/lightgreen))
203 | (tree 400 50 3)
204 | )
205 | )
206 | )
207 |
208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 | ;
210 | ; Create the menu form for the demos.
211 |
212 | (wf/button-stack "Turtle Graphics Demos"
213 | "Draw a Square" drawturtlesquare
214 | "Draw a Circle" drawCircle
215 | "Draw Spiraling Squares" rotating-squares
216 | "Wheel of Color" drawwheelofcolor
217 | "Draw a Star" drawspiralingstar
218 | "Sierpinski's Triangle" #(drawgasket 5)
219 | "Snowflake Fractal" drawsnowflake
220 | "Fractal Tree" drawfractal
221 | )
222 |
--------------------------------------------------------------------------------
/src/htmlutils.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; A set of utilities for generating HTML
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | (using-assembly system.web)
8 |
9 | (defn html/encode [(^string text)]
10 | (.system.web.HttpUtility/HtmlEncode text)
11 | )
12 |
13 | (defn html/doc
14 | "Generate an HTML document"
15 | [header body]
16 | (str
17 | "\n\n\n"
18 | (join (flatten header) "\n")
19 | "\n\n\n"
20 | (join (flatten body) "\n")
21 | "\n\n\n"
22 | )
23 | )
24 |
25 | (defn html/p
26 | "Generate a paragraph tag"
27 | [&args]
28 | (str "" (join (flatten args) "\n") "
")
29 | )
30 |
31 | (defn html/title
32 | "Insert the document title."
33 | [&args]
34 | (str "" (join (flatten args)) "")
35 | )
36 |
37 | (defn html/b
38 | "Bold tag"
39 | [&args]
40 | (str "" (join (flatten args)) "")
41 | )
42 |
43 | (defn html/i
44 | "Italics tag"
45 | [&args]
46 | (str "" (join (flatten args)) "")
47 | )
48 |
49 | (defn html/em
50 | "Emphasis tag"
51 | [&args]
52 | (str "" (join (flatten args)) "")
53 | )
54 |
55 | (defn html/string
56 | "Strong tag"
57 | [&args]
58 | (str "" (join (flatten args)) "")
59 | )
60 |
61 | (defn html/h1
62 | "Generate a header 1 tag."
63 | [&args]
64 | (str "" (join (flatten args)) "
")
65 | )
66 |
67 | (defn html/h2
68 | "Generate a header 2 tag."
69 | [&args]
70 | (str "" (join (flatten args)) "
")
71 | )
72 |
73 | (defn html/h3
74 | "Generate a header 3 tag."
75 | [&args]
76 | (str "" (join (flatten args)) "
")
77 | )
78 |
79 | (defn html/table
80 | "Generate a table"
81 | [&args]
82 | (str "\n\n" (join (flatten args)) "\n
\n")
83 | )
84 |
85 | (defn html/tr
86 | "Generate a table row"
87 | [&args]
88 | (str "\n" (join (flatten args)) "\n
\n")
89 | )
90 |
91 | (defn html/th
92 | "Generate a table header element"
93 | [&args]
94 | (str "" (join (flatten args)) " | ")
95 | )
96 |
97 | (defn html/td
98 | "Generate a table data element."
99 | [&args]
100 | (str "" (join (flatten args)) " | ")
101 | )
102 |
103 | (defn html/style
104 | "Insert an HTML CSS style string."
105 | [styleString]
106 | (str "\n\n")
107 | )
108 |
109 | (defn html/input
110 | "Insert an input element into the document."
111 | [(^IDictionary elements)]
112 |
113 | (let result "\n"))
130 |
131 | result
132 | )
133 |
134 | (defn html/form
135 | "Insert a form into the html document."
136 | [(^IDictionary elements) &args]
137 |
138 | (let result "")
139 |
140 | (let result "\n")
156 | )
157 |
158 | (defn html/extractLinks
159 | "
160 | A function to extract all of the links in a piece of HTML text.
161 | Currently it doesn't distinguish between \" and \'. It also
162 | doesn't handle relative links because it doesn't have the original URL.
163 |
164 | Examples:
165 | (http/get | html/extractLinks)
166 |
167 | See also: http/get
168 | "
169 | [text]
170 |
171 | (.matches #"href *= *[\"']([^\"']*)[\"']" text
172 | | map (fn m -> (.groups m | !! 1 | .value))
173 | | re/replace-all "^//" "http://"
174 | )
175 | )
176 |
177 | ;
178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
179 | ;
180 | ; Example doc
181 | ;
182 | (comment
183 | (setq doc
184 | (html/doc
185 | (list
186 | (html/title "This is an HTML Document")
187 | (html/style "
188 | body {
189 | font-family: \"Open Sans\", Helvetica, Arial, Sans-Serif;
190 | }
191 | table {
192 | border: 1px solid black;
193 | }
194 | th {
195 | padding: 10px;
196 | text-align: center;
197 | background-color: #e0e0e0;
198 | }
199 | td {
200 | padding: 10px;
201 | text-align: left;
202 | vertical-align: top;
203 | }
204 | tr:nth-child(even) {background-color: #f2f2f2;}
205 | ")
206 | )
207 | (list
208 | (html/h1 "This is an H1 Header")
209 | (html/p
210 | "This is a paragraph"
211 | "split over a number of lines."
212 | "with a" (html/b "Bold section")
213 | "and so on"
214 | )
215 | (html/h2 "This is an H2 Header")
216 | (html/p
217 | "This is a paragraph
218 | as a single string spanning multiple lines
219 | with a ${(html/b \"Bold section\")}
220 | and so on"
221 | )
222 |
223 | (html/table
224 | (html/tr (html/th 'one) (html/th 'two) (html/th 'three))
225 | (html/tr (html/td 1) (html/td 2) (html/td 3))
226 | (html/tr (html/td 1) (html/td 2) (html/td 3))
227 | (html/tr (html/td 1) (html/td 2) (html/td 3))
228 | (html/tr (html/td 1) (html/td 2) (html/td 3))
229 | )
230 |
231 | (html/h2 "Some file information")
232 |
233 | (html/table
234 | (html/tr (html/th 'name) (html/th 'length) (html/th 'Mode) (html/th "Last Write Time"))
235 | (forall fl (ls '*.tl)
236 | (html/tr
237 | (html/td (.name fl))
238 | (html/td (.length fl))
239 | (html/td (.mode fl))
240 | (html/td (.LastWriteTime fl))
241 | )
242 | )
243 | )
244 | )
245 | )
246 | )
247 | ) ; end comment
248 |
--------------------------------------------------------------------------------
/Examples/hanoi.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; A graphical animation of the "Towers of Hanoi" puzzle written in Braid.
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | lambda [(numDisks 4) :auto :fast :width: :height:]
8 |
9 | (using-module winforms)
10 |
11 | (let-default ^int width 2 4)
12 | (let-default ^int height 2 4)
13 |
14 | (type-alias ^Color ^System.Drawing.Color)
15 | (type-alias ^ContentAlignment ^System.Drawing.ContentAlignment)
16 | (type-alias ^Label ^System.Windows.Forms.Label)
17 | (type-alias ^Button ^System.Windows.Forms.Button)
18 | (type-alias ^Form ^System.Windows.Forms.Form)
19 | (type-alias ^Application ^System.Windows.Forms.Application)
20 | (type-alias ^DragDropEffects ^System.Windows.Forms.DragDropEffects)
21 |
22 | (let DiskHeight (* height 20))
23 | (let DiskWidthFactor (* width 20))
24 | (let Top 100)
25 | (let UpperBound (- top diskHeight))
26 | (let TowerOffset (+ 100 DiskWidthFactor))
27 | (let TowerWidth (numDisks | * DiskWidthFactor))
28 | (let BaseY (+ top (* numDisks diskHeight)))
29 | (let Delay 1)
30 |
31 | ;---------------------------------------------------------------
32 | ;
33 | ; A type to model a single tower.
34 | ;
35 | (deftype ^Tower -extends: ^Label
36 |
37 | ^Vector disks
38 | ^int center
39 |
40 | :defm new (fn this id center ->
41 | (this
42 | | .text (str "T" id)
43 | | .width TowerWidth
44 | | .Height DiskHeight
45 | | .center center
46 | | .Left (center | - (/ TowerWidth 2))
47 | | .Top BaseY
48 | | .backcolor .Color/Green
49 | | .forecolor .Color/White
50 | | .textAlign .ContentAlignment/MiddleCenter
51 | | .disks []
52 | | .AllowDrop true
53 | )
54 |
55 | (.add_DragEnter this
56 | (^System.Windows.Forms.DragEventHandler?
57 | (fn sender e ->
58 | (.effect e .DragDropEffects/Copy)
59 | (info (+ "in DragEnter " (.text this)))
60 | )
61 | )
62 | )
63 |
64 | (.add_DragDrop this
65 | (^System.Windows.Forms.DragEventHandler?
66 | (fn sender e ->
67 | (info "in DragDrop")
68 | (.backcolor this .color/red)
69 | )
70 | )
71 | )
72 | )
73 |
74 | :defm addDisk (fn this disk ->
75 | (if (and disks (!! disks 0 | .width | < (.width disk)))
76 | (throw "Bigger disks can't go on smaller disks.")
77 | )
78 | )
79 | )
80 |
81 | ;---------------------------------------------------------------
82 | ;
83 | ; A type to model a single disk
84 | ;
85 | (deftype ^Disk -extends: ^Button
86 |
87 | :defm new (fn this (^int width) ->
88 | ; construct a new disk. Each disk is positioned lower than the previous one
89 | (this
90 | | .Width (* DiskWidthFactor width)
91 | | .Height diskHeight
92 | | .Top (pincr top diskHeight)
93 | | .Left (towerOffset | - (* DiskWidthFactor width | / 2) | ^int?)
94 | | .BackColor (wf/next-color)
95 | | .AllowDrop true
96 | )
97 |
98 | ; drag and drop
99 | (.add_MouseDown this
100 | (^System.Windows.Forms.MouseEventHandler?
101 | (fn sender e ->
102 | (.DoDragDrop this this .DragDropEffects/Move)
103 | )
104 | )
105 | )
106 | )
107 |
108 | :defm Reset (fn this -> (.left this (towerOffset | - (.width this | / 2) | ^int?)))
109 |
110 | :defm MoveUp (fn this -> (.top this (.top this | - diskHeight)))
111 |
112 | :defm MoveDown (fn this -> (.top this (.top this | + diskHeight)))
113 |
114 | :defm MoveLeft (fn this -> (.left this (.left this | - 20)))
115 |
116 | :defm MoveRight (fn this -> (.left this (.left this | + 20)))
117 |
118 | ;
119 | ; animate moving a disk from one tower to another.
120 | ;
121 | :defm Move (fn this (^tower t1) (^tower t2) ->
122 |
123 | (.disks t1 | .remove this)
124 |
125 | ; move this disk up, refreshing just the disk control
126 | (while (.top this | >= upperBound)
127 | (.moveUp this)
128 | (unless fast
129 | (.update this)
130 | (sleep 5)
131 | )
132 | )
133 |
134 | ; move this disk over, right or left
135 | (let dist (.center t2 | - (.center t1)))
136 | (if (neg? dist)
137 | (for (let dist (abs dist)) (> dist 0) (incr dist -20)
138 | (.moveLeft this)
139 | (unless fast
140 | (.update this)
141 | (sleep 5)
142 | )
143 | )
144 | ; otherwise
145 | (while (> dist 0)
146 | (.moveRight this)
147 | (unless fast
148 | (.update this)
149 | (sleep 5)
150 | )
151 | (incr dist -20)
152 | )
153 | )
154 |
155 | ; move this disk down
156 | (let targetTop
157 | (if (.disks t2)
158 | (.disks t2 | !! -1 | .top)
159 | (.top t2)))
160 |
161 | (let downDist (- targetTop (+ (.top this) diskHeight)))
162 |
163 | (while (> downDist 0)
164 | (.moveDown this)
165 | (incr downDist (neg diskHeight))
166 | (unless fast
167 | (.update this)
168 | (sleep 5)
169 | )
170 | )
171 |
172 | (.disks t2 | .add this)
173 |
174 | ; now update the entire form instead of just the disk
175 | (.TopLevelControl this | .update)
176 |
177 | (if fast
178 | (when (.datetime/now | .millisecond | % 500 | == 0)
179 | (.TopLevelControl this | .update)
180 | )
181 | (do
182 | (.TopLevelControl this | .update)
183 | )
184 | )
185 |
186 | (sleep 1)
187 | )
188 | )
189 |
190 | ;---------------------------------------------------------------
191 | ;
192 | ; A type to encapsulate the whole puzzle
193 | ;
194 | (deftype ^TowersOfHanoi -extends: ^Form
195 |
196 | ^Vector Towers
197 | ^Vector Disks
198 |
199 | ;
200 | ; Constructor for the puzzle.
201 | ;
202 | :defm new (fn this ->
203 | (this
204 | | .Text "Towers of Hanoi"
205 | | .Height (+ baseY (* diskHeight 4))
206 | | .Backcolor .Color/black
207 | | .StartPosition .System.Windows.Forms.FormStartPosition/CenterScreen
208 | | .FormBorderStyle .System.Windows.Forms.FormBorderStyle/FixedDialog
209 | | .MaximizeBox false
210 | | .MinimizeBox false
211 | )
212 |
213 | ; manual start
214 | (.add_Click this
215 | (^EventHandler?
216 | (fn e o -> (.run this))
217 | )
218 | )
219 |
220 | ; automatic start
221 | (.add_Shown this
222 | (^EventHandler?
223 | (fn e o ->
224 | (when auto
225 | (.Run this)
226 | (sleep 300)
227 | (.close this)
228 | )
229 | )
230 | )
231 | )
232 |
233 | ; Create the all disks and add them to the form
234 | (.Disks this
235 | (forall width (range 1 NumDisks)
236 | (.controls this | .add (let disk (new ^disk width)))
237 | disk
238 | )
239 | )
240 |
241 | ; create the three towers
242 | (let t1 (new ^tower 1 TowerOffset))
243 | (.controls this | .add t1)
244 |
245 | (let t2 (new ^tower 2 (+ (.right t1) (/ TowerWidth 2 | ^int) 20)))
246 | (.controls this | .add t2)
247 |
248 | (let t3 (new ^tower 3 (+ (.right t2) (/ TowerWidth 2 | ^int) 20)))
249 | (.controls this | .add t3)
250 |
251 | (.Towers this [t1 t2 t3])
252 |
253 | (.ResetDisks this)
254 |
255 | (.width this (.right t3 | + TowerWidth))
256 | )
257 |
258 | ; Run the animation.
259 | :defm Run (fn this ->
260 | (.ResetDisks this)
261 | (.update this)
262 | (.dohanoi this numDisks 3 1 2)
263 | (.update this)
264 | )
265 |
266 | ;
267 | ; Method to move all of the disks (back) to the first tower.
268 | ;
269 | :defm ResetDisks (fn this ->
270 | (foreach t (.Towers this)
271 | (.disks t | .clear)
272 | )
273 |
274 | (let t1 (.Towers this | !! 0))
275 | (foreach d (.Disks this)
276 | (.Reset d)
277 | (.disks t1 | .insert 0 d)
278 | )
279 | )
280 |
281 | ;
282 | ; Method that implements the the core ToH recursive algorithm.
283 | ;
284 | :defm doHanoi (fn this n to from using ->
285 | (if (== n 1)
286 | (do
287 | (let t1 (.Towers this | !! (-- from)))
288 | (let t2 (.Towers this | !! (-- to)))
289 | (.move (.disks t1 | last) t1 t2)
290 | ; flush queued events
291 | (.System.Windows.Forms.Application/doEvents)
292 | (sleep Delay)
293 | )
294 | ; otherwise
295 | (do
296 | (decr n)
297 | (.DoHanoi this n using from to)
298 |
299 | (let t1 (.Towers this | !! (-- from)))
300 | (let t2 (.Towers this | !! (-- to)))
301 | (.Move (.Disks t1 | last) t1 t2)
302 | ; flush queued events
303 | (.Application/doEvents)
304 | (sleep Delay)
305 |
306 | (.doHanoi this n to using from)
307 | )
308 | )
309 | )
310 | )
311 |
312 | ;
313 | ; Create and start the puzzle.
314 | ;
315 | ;(new ^TowersOfHanoi | .Application/Run | void)
316 | (new ^TowersOfHanoi | .ShowDialog | void)
317 |
--------------------------------------------------------------------------------
/Examples/snake.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; A Braid script that implements a variation on the arcade game 'Snake'.
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | lambda [
8 | :numPellets: ; number of pellets to consume
9 | :delay: ; delay between movements
10 | :game-time: ; how long the game lasts
11 | ]
12 |
13 | (using-module Console)
14 |
15 | ;
16 | ; Process defaults for the game
17 | ;
18 |
19 | (let-default numPellets 15)
20 | (let-default delay 150)
21 | (let-default game-time 150)
22 |
23 | ;
24 | ; Initial list of segments that make up the snake's body
25 | ; where body elements are '=' and the head is '@' e.g. =====@
26 | ;
27 | (let SegmentList
28 | [
29 | [13 25] ; the end of the tail.
30 | [14 25]
31 | [15 25]
32 | [16 25]
33 | [17 25]
34 | [18 25]
35 | [19 25]
36 | [20 25]
37 | [21 25] ; the head @ is the last segment in the list
38 | ]
39 | )
40 |
41 | ;
42 | ; The direction the snake is currently moving in (e -east - by default)
43 | ;
44 | (let Direction "e")
45 |
46 | ;
47 | ; Function to draw the snake on the screen. Uses 'recur'
48 | ; instead of an imperative loop. Print the snake from the
49 | ; head (@) to the tail (=) (i.e backwards)
50 | ;
51 | (defn Render
52 | [(segcount (-- (count SegmentList))) (charToPrint "@")]
53 |
54 | (Console/writeat @(SegmentList segcount) charToPrint)
55 |
56 | (if (> segcount 0)
57 | (recur (-- segcount) "=")
58 | )
59 | )
60 |
61 | ;
62 | ; Move the snake one cell forward in the current direction.
63 | ;
64 | (defn Move
65 | []
66 |
67 | ; See if the snake ate a pellet i.e. the head location is the same as the tail location.
68 | (let atePellet (CheckForPellet (last SegmentList)))
69 | (let tl nil)
70 |
71 | ; If we didn't get a pellet, remove the last segment
72 | (unless atePellet
73 | (let tl (!! SegmentList 0))
74 | (Console/writeat @tl " ")
75 | (.removeat SegmentList 0)
76 | )
77 |
78 | ; Duplicate the head of the snake so we can update it.
79 | (let lst (last SegmentList))
80 | (let snakeHead [ @lst ])
81 | (matchp Direction
82 | | "n" ->
83 | (if (>= (snakeHead 1) (- (.Console/WindowHeight) 2))
84 | (def Direction "e")
85 | (snakeHead 1 (++ (snakeHead 1)))
86 | )
87 |
88 | | "s" ->
89 | (if (<= (snakeHead 1) 0)
90 | (def Direction "w")
91 | (snakeHead 1 (-- (snakeHead 1)))
92 | )
93 |
94 | | "e" ->
95 | (if (>= (++ (first snakeHead)) (.Console/WindowWidth))
96 | (def Direction "s")
97 | (snakeHead 0 (++ (first snakeHead)))
98 | )
99 |
100 | | "w" ->
101 | (if (< (-- (first snakeHead)) 0)
102 | (def Direction "n")
103 | (snakeHead 0 (-- (first snakeHead)))
104 | )
105 | )
106 |
107 | (.add SegmentList snakeHead)
108 |
109 | (render)
110 | )
111 |
112 | (let Score 0) ; multiple of the number of pellets consumed
113 |
114 | (let Pellets []) ; List of the pellet locations
115 |
116 | (let StatusColor .ConsoleColor/cyan)
117 |
118 | ; Function to show the game status.
119 | (defn ShowStatus
120 | []
121 |
122 | (let oldFg (.Console/ForeGroundColor))
123 | (let secondsRemaining (timeRemaining | .totalSeconds | ^int?))
124 |
125 | (let StatusColor
126 | (if (<= secondsRemaining 30)
127 | ; If time is running out, blink the status bar red and yellow.
128 | (if (== Statuscolor .ConsoleColor/yellow) .consolecolor/red .consolecolor/yellow)
129 | (.Consolecolor/cyan)
130 | )
131 | )
132 |
133 | (.Console/ForegroundColor Statuscolor)
134 | (Console/writeat 0 (- (.Console/WindowHeight) 1)
135 | (.string/format
136 | "Score: {0,3} Pellets remaining {1,3} Time remaining: {2,3} seconds. "
137 | score
138 | (length pellets)
139 | secondsRemaining
140 | )
141 | )
142 | (.Console/ForegroundColor oldFg)
143 | )
144 |
145 | ;
146 | ; Initialize the pellet field
147 | ;
148 | (defn Initialize []
149 | ; Generate the pellet locations by taking two random lists and zipping them together.
150 | (let snake_len (length SegmentList))
151 | (let oldFg (.Console/ForeGroundColor))
152 |
153 | (def pellets
154 | (random (+ numpellets snake_len) 1 (.Console/WindowWidth)
155 | | zip (random (+ numPellets snake_len) 1 (- (.Console/WindowHeight) 3))
156 | ; make sure none of them land on the snake
157 | | filter -not (fn p -> (contains? SegmentList p))
158 | | first numPellets
159 | )
160 | )
161 |
162 | ; Then draw the pellets on the screen.
163 | (.Console/ForegroundColor .ConsoleColor/green)
164 | (foreach p pellets
165 | (Console/writeat @p "o")
166 | )
167 |
168 | (.Console/ForegroundColor oldFg)
169 | (ShowStatus)
170 | )
171 |
172 | (let ColorList [.Consolecolor/yellow .Consolecolor/green .Consolecolor/cyan .Consolecolor/magenta .Consolecolor/red])
173 | (let ColorIndex 0)
174 |
175 | (defn NextColor []
176 | (def colorIndex (% (+ colorIndex 1) (length ColorList)))
177 | (ColorList ColorIndex)
178 | )
179 |
180 | ;
181 | ; Function that handles the case where the snake eats a pellet.
182 | ; Does the eating animation.
183 | ;
184 | (defn CheckForPellet [location]
185 | ; See if the pellet list contains this location
186 | (if (contains? Pellets location)
187 | (do
188 | ; If so, show the eating animation
189 | (let oldFg (.Console/ForeGroundColor))
190 |
191 | (foreach it (range 0 3)
192 | (.Console/ForegroundColor .ConsoleColor/red)
193 | (Console/writeat @location "X")
194 | (sleep 75)
195 | (Console/writeat @location "+")
196 | (sleep 75)
197 | )
198 |
199 | (.Console/ForegroundColor oldFg)
200 |
201 | ; Increment the score
202 | (incr score 10)
203 |
204 | ; And remove the pellet from the list.
205 | (def Pellets (Pellets | filter (!= location)))
206 | (showStatus)
207 |
208 | ; Change the snakes color
209 | (.Console/ForegroundColor (NextColor))
210 | true
211 | )
212 | (do
213 | (showStatus)
214 | false
215 | )
216 | )
217 | )
218 |
219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220 | ;
221 | ; The main game loop.
222 | ;
223 |
224 | (def oldFg (.Console/ForeGroundColor))
225 |
226 | (try
227 | -finally: (fn e ->
228 | (.Console/CursorVisible true)
229 | (Console/ForeColor oldFg)
230 | (error "Snake error:" e)
231 | )
232 |
233 | (cls)
234 | (.Console/CursorVisible false)
235 |
236 | (def key
237 | (.key
238 | (Announce
239 | (.string/format (qstr
240 | Welcome to the Snake Game. Your job is to guide the snake
241 | over the playing field so it can eat all of the food pellets.
242 | If you get all of the pellets before the time runs "out," you
243 | win! In this game, you have to eat "{0}" pellets
244 | in "{1}" seconds. Use the arrow keys to control the
245 | "snake's" direction, the space bar will cause the snake to have a burst of speed.
246 | You can quit at any time by pressing "'q'". Get ready to play!)
247 | numPellets game-time
248 | )
249 | "green"
250 | )
251 | )
252 | )
253 |
254 | (if (== key "q")
255 | (do
256 | (cls)
257 | (println "Thanks for playing! Bye bye!")
258 | (return)
259 | )
260 | )
261 |
262 | (cls)
263 | (let fastCount 0) ; The number of iterations to move the snake quickly.
264 | (.Console/ForegroundColor .ConsoleColor/yellow)
265 | (let endTime (.datetime/now | .AddSeconds game-time))
266 | (let timeRemaining (- endTime (.datetime/now)))
267 | (Initialize)
268 | (Render)
269 | (while true
270 | (Move)
271 | (let timeRemaining (- endTime (.datetime/now)))
272 |
273 | ; If time runs out, you lose.
274 | (when (<= timeRemaining 0)
275 | (let msg (.string/format
276 | "Time has run out and the game is over! You earned {0} points; There were {1} pellets left."
277 | score (length pellets)))
278 | (Announce msg "yellow")
279 | (cls)
280 | (break)
281 | )
282 |
283 | ; If the pellet count is zero, you win the game.
284 | (if (zero? (length pellets))
285 | (do
286 | (Announce
287 | (str
288 | "Game over! You win with " Score " points "
289 | "and " (^int? (. timeRemaining 'TotalSeconds))
290 | " seconds left. Congratulations!"
291 | )
292 | "green"
293 | )
294 |
295 | (cls)
296 | (break)
297 | )
298 | )
299 |
300 | ; Figure out if we should iterate slow or fast.
301 | (if (== fastCount 0)
302 | (sleep delay)
303 | (decr fastCount)
304 | )
305 |
306 | ; Process the user key presses.
307 | (if (.Console/KeyAvailable)
308 | (matchp (.Console/ReadKey true)
309 | | {Key .Consolekey/LeftArrow} -> (def Direction "w")
310 | | {Key .Consolekey/RightArrow} -> (def Direction "e")
311 | | {Key .Consolekey/UpArrow} -> (def Direction "s")
312 | | {Key .Consolekey/DownArrow} -> (def Direction "n")
313 | | {Key .Consolekey/f} -> (def FastCount 20)
314 | | {Key .Consolekey/Spacebar} -> (def FastCount 20)
315 | | {Key .Consolekey/q} ->
316 | (Announce "Thanks for playing! Hope you had a good time!")
317 | (cls)
318 | (break)
319 | | -> ; ignore all other key presses
320 | )
321 | )
322 | )
323 | ) ; try
324 |
325 | (.Console/CursorVisible true)
326 | (Console/ForeColor oldFg)
327 | (println "Bye bye!")
328 |
329 |
--------------------------------------------------------------------------------
/src/symbol.cs:
--------------------------------------------------------------------------------
1 | /////////////////////////////////////////////////////////////////////////////
2 | //
3 | // The Braid Programming Language - the Symbol type
4 | //
5 | //
6 | // Copyright (c) 2023 Bruce Payette (see LICENCE file)
7 | //
8 | ////////////////////////////////////////////////////////////////////////////
9 |
10 | using System;
11 | using System.Linq;
12 | using System.Text.RegularExpressions;
13 | using System.Collections.Generic;
14 | using System.Collections.Concurrent;
15 | using System.Threading;
16 |
17 | namespace BraidLang
18 | {
19 | /////////////////////////////////////////////////////////////////////////
20 | ///
21 | /// Represents a symbol in Braid. Symbols are interned.
22 | ///
23 | public sealed class Symbol : IEquatable, IComparable
24 | {
25 | public string Value { get; private set; }
26 |
27 | public int SymId { get { return _symId; } }
28 | int _symId;
29 |
30 | // Members used for multiple assignment.
31 | public List ComponentSymbols;
32 | public bool CompoundSymbol;
33 | public bool _bindRestToLast = true;
34 |
35 | static int _nextSymId;
36 |
37 | // Used to intern symbols
38 | public static ConcurrentDictionary _symbolTable =
39 | new ConcurrentDictionary(StringComparer.OrdinalIgnoreCase);
40 |
41 | // Get the symbol corresponding to a string. Create a new symbol if one doesn't exist.
42 | public static Symbol FromString(string name)
43 | {
44 | lock (_lockObj)
45 | {
46 | if (_symbolTable.TryGetValue(name, out Symbol symout))
47 | {
48 | return symout;
49 | }
50 |
51 | var sym = new Symbol(name);
52 | _symbolTable[name] = sym;
53 | return sym;
54 | }
55 | }
56 |
57 | // Generate a new unique symbol
58 | public static Symbol GenSymbol()
59 | {
60 | lock (_lockObj)
61 | {
62 | string name = "sym_" + Braid._rnd.Next().ToString();
63 | var sym = new Symbol(name);
64 | _symbolTable[name] = sym;
65 | return sym;
66 | }
67 | }
68 |
69 | //
70 | // Get the symbol corresponding to the specified name.
71 | // Don't create a symbol if there isn't already one, just
72 | // return null in that case.
73 | //
74 | public static Symbol GetSymbol(string symbolName)
75 | {
76 | Symbol symbol;
77 | if (_symbolTable.TryGetValue(symbolName, out symbol))
78 | {
79 | return symbol;
80 | }
81 | else
82 | {
83 | return null;
84 | }
85 | }
86 |
87 | static object _lockObj = new object();
88 |
89 | Symbol(string val)
90 | {
91 | if (string.IsNullOrEmpty(val))
92 | {
93 | Braid.BraidRuntimeException("Cannot create a symbol with an empty name.");
94 | }
95 |
96 | this.Value = val;
97 | if (val.Length > 1 && val.Contains(":"))
98 | {
99 | CompoundSymbol = true;
100 | ComponentSymbols = new List();
101 | string[] elements = val.Split(':');
102 | // If the last segment is empty, remove it so patterns
103 | // like a:b:c: match [1 2 3]
104 | int numElements = elements.Length;
105 | if (elements[elements.Length - 1].Length == 0)
106 | {
107 | numElements--;
108 | _bindRestToLast = false;
109 | }
110 |
111 | // Add the names as symbols to the list
112 | for (var i = 0; i < numElements; i++)
113 | {
114 | ComponentSymbols.Add(Symbol.FromString(elements[i]));
115 | }
116 | }
117 |
118 | this._symId = Interlocked.Increment(ref _nextSymId);
119 | }
120 |
121 | // Implicit conversion from symbol to string/regex and vise versa.
122 | public static implicit operator string(Symbol s) => s.Value;
123 | public static implicit operator Symbol(string str) =>
124 | Symbol.FromString(str);
125 | public static implicit operator Regex(Symbol s) =>
126 | new Regex(s.Value,
127 | RegexOptions.IgnoreCase | RegexOptions.CultureInvariant);
128 | public static implicit operator Symbol(Regex re) =>
129 | Symbol.FromString(re.ToString());
130 |
131 | public override string ToString()
132 | {
133 | return Value;
134 | }
135 |
136 | public override bool Equals(object obj)
137 | {
138 | if (obj == null) return false;
139 | if (obj is Symbol sobj)
140 | {
141 | return this._symId == sobj._symId;
142 | }
143 | else
144 | {
145 | return false;
146 | }
147 | }
148 |
149 | public bool Equals(Symbol sym) => this._symId == sym._symId;
150 |
151 | public override int GetHashCode() => _symId;
152 |
153 | public int CompareTo(object obj)
154 | {
155 | if (obj is Symbol sym)
156 | {
157 | if (this.SymId == sym.SymId)
158 | return 0;
159 |
160 | return string.Compare(Value, sym.Value, StringComparison.OrdinalIgnoreCase);
161 | }
162 | else
163 | {
164 | return -1;
165 | }
166 | }
167 |
168 | public static void DumpSymbols()
169 | {
170 | Console.WriteLine("Dumping symbols:");
171 | foreach (var sym in _symbolTable.Values.OrderBy((n) => n.SymId))
172 | {
173 | Console.WriteLine($"{sym.SymId,4} '{sym}'");
174 | }
175 | }
176 |
177 | ////////////////////////////////////////////////////////////////
178 | //
179 | // Pre-defined symbols
180 | //
181 | ////////////////////////////////////////////////////////////////
182 |
183 | // These symbols must be first.
184 | public static Symbol sym_quote = Symbol.FromString("quote");
185 | public static Symbol sym_lambda = Symbol.FromString("lambda");
186 | public static Symbol sym_splat = Symbol.FromString("splat");
187 | public static Symbol sym_quasiquote = Symbol.FromString("quasiquote");
188 | public static Symbol sym_unquote = Symbol.FromString("unquote");
189 | public static Symbol sym_unquotesplat = Symbol.FromString("unquotesplat");
190 |
191 | // Remaining predefined symbols...
192 | public static Symbol sym_nil = Symbol.FromString("nil");
193 | public static Symbol sym_null = Symbol.FromString("null");
194 | public static Symbol sym_args = Symbol.FromString("args");
195 | public static Symbol sym_and_args = Symbol.FromString("&args");
196 | public static Symbol sym_named_parameters = Symbol.FromString("named-parameters");
197 |
198 | public static Symbol sym_it = Symbol.FromString("it");
199 | public static Symbol sym_it2 = Symbol.FromString("it2");
200 | public static Symbol sym_this = Symbol.FromString("this");
201 | public static Symbol sym_keywords = Symbol.FromString("keywords");
202 | public static Symbol sym_defn = Symbol.FromString("defn");
203 | public static Symbol sym_defspecial = Symbol.FromString("defspecial");
204 | public static Symbol sym_defmacro = Symbol.FromString("defmacro");
205 | public static Symbol sym_deftype = Symbol.FromString("deftype");
206 | public static Symbol sym_definterface = Symbol.FromString("definterface");
207 | public static Symbol sym_defrecord = Symbol.FromString("defrecord");
208 | public static Symbol sym_dot = Symbol.FromString(".");
209 | public static Symbol sym_true = Symbol.FromString("true");
210 | public static Symbol sym_false = Symbol.FromString("false");
211 |
212 | public static Symbol sym_dispatch = Symbol.FromString("dispatch");
213 | public static Symbol sym_underbar = Symbol.FromString("_");
214 | public static Symbol sym_pipe = Symbol.FromString("|");
215 | public static Symbol sym_matches = Symbol.FromString("Matches");
216 | public static Symbol sym_matchp = Symbol.FromString("matchp");
217 | public static Symbol sym_let = Symbol.FromString("let");
218 | public static Symbol sym_with = Symbol.FromString("with");
219 | public static Symbol sym_argindex_0 = Symbol.FromString("%0");
220 | public static Symbol sym_recur = Symbol.FromString("recur");
221 | public static Symbol sym_recur_to = Symbol.FromString("recur-to");
222 | public static Symbol sym_loop = Symbol.FromString("loop");
223 | public static Symbol sym_new = Symbol.FromString("new");
224 | public static Symbol sym_new_dict = Symbol.FromString("new-dict");
225 | public static Symbol sym_new_vector = Symbol.FromString("new-vector");
226 | public static Symbol sym_to_vector = Symbol.FromString("to-vector");
227 | public static Symbol sym_join = Symbol.FromString("join");
228 | public static Symbol sym_tostring = Symbol.FromString("tostring");
229 | public static Symbol sym_compareto = Symbol.FromString("compareto");
230 | public static Symbol sym_gethashcode = Symbol.FromString("gethashcode");
231 | public static Symbol sym_equals = Symbol.FromString("Equals");
232 | public static Symbol sym_mod = Symbol.FromString("%");
233 | public static Symbol sym_add = Symbol.FromString("+");
234 | public static Symbol sym_subtract = Symbol.FromString("-");
235 | public static Symbol sym_multiply = Symbol.FromString("*");
236 | public static Symbol sym_divide = Symbol.FromString("/");
237 | public static Symbol sym_gt = Symbol.FromString(">");
238 | public static Symbol sym_ge = Symbol.FromString(">=");
239 | public static Symbol sym_lt = Symbol.FromString("<");
240 | public static Symbol sym_le = Symbol.FromString("<=");
241 | public static Symbol sym_prior_task = Symbol.FromString("prior-task");
242 | public static Symbol sym_task_args = Symbol.FromString("task-args");
243 | public static Symbol sym_prior_result = Symbol.FromString("prior-result");
244 | public static Symbol sym_arrow = Symbol.FromString("->");
245 | public static Symbol sym_leftarrow = Symbol.FromString("<-");
246 | public static Symbol sym_fail = Symbol.FromString("!");
247 | public static Symbol sym_smaller = Symbol.FromString("smaller");
248 | public static Symbol sym_bigger = Symbol.FromString("bigger");
249 | public static Symbol sym_keyword = Symbol.FromString("where");
250 | }
251 | }
252 |
--------------------------------------------------------------------------------
/Examples/consoleform.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; Module that lets you build fullscreen forms on the console
4 | ;
5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 |
7 | (using-module console)
8 |
9 | ;---------------------------------------------------
10 | ;
11 | ; define the "widget" types
12 | ;
13 | ;---------------------------------------------------
14 |
15 | ;
16 | ; base type for inactive widgets like label and box
17 | ;
18 | (deftype ^Inactive)
19 |
20 | ;
21 | ; Define the label widget
22 | ;
23 | (defType ^label -extends: ^Inactive
24 | ^int x
25 | ^int y
26 | ^string text
27 |
28 | :defm render (\ this ->
29 | (console/writeat -foreground: "cyan" (.x this) (.y this) (.text this))
30 | )
31 | )
32 |
33 | ;
34 | ; Define a box render object
35 | ;
36 | (deftype ^box -extends: ^Inactive
37 | ^int x
38 | ^int y
39 | ^int length
40 | ^int width
41 | ^consolecolor? color
42 |
43 | :defm render (\ this ->
44 | (drawbox (.x this) (.y this) (.length this) (.width this) (.color this))
45 | )
46 |
47 | :defm new (\ this x y length width (^consolecolor? color) ->
48 | (this
49 | | .x x
50 | | .y y
51 | | .length length
52 | | .width width
53 | | .color color
54 | )
55 | )
56 | )
57 |
58 | ;
59 | ; Define the button widget
60 | ;
61 | (deftype ^button
62 | ^int x
63 | ^int Y
64 | ^string text
65 | ^int width
66 | Action ; Holds a callback that implements the button's action.
67 | ; It's called with the parent control as it's first parameter
68 |
69 | :defm render (\ this ->
70 | ; center and frame the button
71 | (let pad (^int (/ (- (.width this) (length (.text this))) 2)))
72 | (let text (str "<" (* " " pad) (.text this) (* " " pad) ">"))
73 | (console/writeat (.x this) (.y this) text)
74 | )
75 |
76 | :defm Activate (\ this ->
77 | (let oldfg (.console/foregroundcolor))
78 | (let oldbg (.console/backgroundcolor))
79 | (.console/foregroundcolor .consolecolor/black)
80 | (.console/backgroundcolor .consolecolor/yellow)
81 | (.render this)
82 |
83 | (let keypress "")
84 | (matchp @(console/readkey)
85 | | _ "DownArrow" _ ->
86 | (let keypress ["DownArrow"])
87 |
88 | | _ "UpArrow" _ ->
89 | (let keypress ["UpArrow"])
90 |
91 | | _ "LeftArrow" _ ->
92 | (let keypress ["LeftArrow"])
93 |
94 | | _ "RightArrow" _ ->
95 | (let keypress ["RightArrow"])
96 |
97 | | _ "Enter" _ ->
98 | (let keypress ["Action" (.action this)])
99 |
100 | | _ "SpaceBar" _ ->
101 | (let keypress ["Action" (.action this)])
102 |
103 | | _ "Tab" "Shift" ->
104 | (let keypress ["ShiftTab"])
105 |
106 | | _ "Tab" _ ->
107 | (let keypress ["Tab"])
108 |
109 | | _ "Escape" _ ->
110 | (let KeyPress ["Escape"])
111 |
112 | | -> ; ignore all of the other keys
113 | )
114 |
115 | (.console/foregroundcolor oldFg)
116 | (.console/backgroundcolor oldBg)
117 | (.render this)
118 | keypress
119 | )
120 | )
121 |
122 | ;
123 | ; Define the editable field widget
124 | ;
125 | (deftype ^Field
126 | ^int x
127 | ^int y
128 | ^string Name
129 | ^int Width
130 | ^string CurrentText
131 | ^string HelpText
132 |
133 | ; Method to render the field
134 | :defm render (\ this ->
135 | (console/writeat (-- (.x this)) (.y this) (str "[" (* " " (.width this)) "]"))
136 | (console/writeat (.x this) (.y this) (.currenttext this))
137 | )
138 |
139 | :defm Activate (\ this ->
140 |
141 | (let result (.CurrentText this))
142 | (let keypress "")
143 | (let oldfg (.console/foregroundcolor))
144 | (let oldbg (.console/backgroundcolor))
145 | ; this call is not supported on all platforms so swallow the error
146 | (let oldCursor true)
147 | (try (let oldCursor (.console/cursorvisible)))
148 |
149 | (try
150 | (.console/foregroundcolor oldBg)
151 | (.console/backgroundcolor oldFg)
152 | ; this call is not supported on all platforms so swallow the error
153 | (try (.console/cursorSize 25))
154 | (.console/cursorvisible true)
155 |
156 | (.console/SetCursorPosition (.x this) (.y this))
157 | (let pos (.console/cursorleft))
158 | (let endx (.x this | + (.width this) | - 1))
159 | (let loop true)
160 | (while loop
161 | ; first blank the field, then write it
162 | (console/writeat (.x this) (.y this) (* " " (.width this)))
163 | (console/writeat (.x this) (.y this) (.currenttext this))
164 | (.console/setcursorposition (^int pos) (.y this))
165 |
166 | (let maxtext (+ (.x this) (length (.currenttext this))))
167 | (matchp @(console/readkey)
168 | | _ "DownArrow" _ ->
169 | (let KeyPress "DownArrow")
170 | (let loop false)
171 |
172 | | _ "UpArrow" _ ->
173 | (let KeyPress "UpArrow")
174 | (let loop false)
175 |
176 | | _ "LeftArrow" _ ->
177 | (.console/setcursorposition (^int (decr pos)) (.y this))
178 | (when (< pos (.x this)) (let pos (.x this)))
179 |
180 | | _ "RightArrow" _ ->
181 | (.console/setcursorposition (^int (incr pos)) (.y this))
182 | (when (> pos maxtext) (let pos maxtext))
183 |
184 | | _ "End" _ ->
185 | (let pos maxtext)
186 |
187 | | _ "Home" _ ->
188 | (let pos (.x this))
189 |
190 | | _ "Enter" _ ->
191 | (let result (.currenttext this))
192 | (let KeyPress "Enter")
193 | (let loop false)
194 |
195 | | _ "Escape" _ ->
196 | (let KeyPress "Escape")
197 | (let loop false)
198 |
199 | | _ "Tab" "Shift" ->
200 | (let KeyPress "ShiftTab")
201 | (let loop false)
202 |
203 | | _ "Tab" _ ->
204 | (let KeyPress "Tab")
205 | (let loop false)
206 |
207 | | _ "Backspace" _ ->
208 | (let deletePos (- (^int32 pos) (.x this)))
209 | (when (> deletePos 0)
210 | (let text (.currentText this))
211 | (let text
212 | (str
213 | (.substring text 0 (- deletePos 1))
214 | (.substring text deletePos)
215 | )
216 | )
217 | (.currentText this text)
218 | (decr pos)
219 | (when (< pos (.x this))
220 | (let pos (.x this))
221 | )
222 | )
223 |
224 | | key _ _ ->
225 | (when (re/match key #"[0-9a-z _]")
226 | (let insertPos (- (^int32 pos) (.x this)))
227 | (let text (.currentText this))
228 | (let text (str (.substring text 0 insertPos) key (.substring text insertPos)))
229 | (when (length text | < (.width this))
230 | (.currentText this text)
231 | (incr pos)
232 | (when (> pos endx)
233 | (let pos endx)
234 | )
235 | )
236 | )
237 | | -> ; ignore everything else
238 | )
239 | )
240 |
241 |
242 | -finally:
243 | (do
244 | (.console/foregroundcolor oldFg)
245 | (.console/backgroundcolor oldBg)
246 | (.console/cursorvisible oldCursor)
247 | (.render this)
248 | )
249 | ) ; try
250 | [keypress result]
251 | )
252 | )
253 |
254 | ;---------------------------------------------------
255 | ;
256 | ; The console form class. This is the one you actually
257 | ; work with
258 | ;
259 | (deftype ^ConsoleForm
260 |
261 | ; The form title
262 | ^string Title
263 |
264 | ; All renderable form elements (label, button and field)
265 | ^Vector Elements
266 |
267 | ; All activatable form elements (button and field)
268 | ^IDictionary Fields
269 |
270 | ; Index of the current form element
271 | ^int Index
272 |
273 | :defm new (\ this title -> (this | .Elements [] | .Fields {} | .Title title))
274 |
275 | :defm AddField (\ this x y name width initialText helpText ->
276 | (let field (new ^field x y name width initialText helptext))
277 | (!! (.fields this) name field)
278 | (.Elements this | .add field)
279 | this
280 | )
281 |
282 | :defm AddLabel (\ this x y text ->
283 | (let label (new ^Label x y text))
284 | (.Elements this | .add label)
285 | this
286 | )
287 |
288 | :defm AddBox (\ this x y length width color ->
289 | (let box (new ^Box x y length width "cyan"))
290 | (.Elements this | .add box)
291 | this
292 | )
293 |
294 |
295 | :defm AddButton (\ this x y text width action ->
296 | (let button (new ^button x y text width action))
297 | (.Elements this | .add button)
298 | this
299 | )
300 |
301 | ; method to move to the next activatable field
302 | :defm _moveNext (\ this inc ->
303 | (when (.Elements this)
304 | (.index this (% (+ (.index this) inc) (length (.Elements this))))
305 | (while (!! (.Elements this) (.index this) | is? ^Inactive)
306 | (.index this (% (+ (.index this) inc) (length (.Elements this))))
307 | (if (< (.index this) 0) (.index this (- (length (.Elements this)) 1)))
308 | )
309 | (.render (!! (.elements this) (.index this)))
310 | )
311 | )
312 |
313 | ; while true, keep looping processing input; exit on false
314 | ^bool loop
315 |
316 | ; if true return the form contents otherwise return null.
317 | ^bool accept
318 |
319 | :defm CancelForm (\ this -> (.accept this false) (.loop this false))
320 |
321 | :defm AcceptForm (\ this -> (.accept this true) (.loop this false))
322 |
323 | :defm Activate (\ this ->
324 | (cls)
325 |
326 | (when (not (.Elements this))
327 | (return)
328 | )
329 |
330 | ; render all of the controls
331 | (foreach f (.elements this) (.render f))
332 |
333 | ; select the first activatable control
334 | (.index this 0)
335 |
336 | (._moveNext this 1)
337 |
338 | (.loop this true)
339 | (while (.loop this)
340 | (let key:val:_ (.activate (!! (.Elements this) (.index this)) | append [ null null null ]))
341 | (matchp key
342 | | "Escape" -> (.loop this false)
343 | | "LeftArrow" -> (._MoveNext this -1)
344 | | "UpArrow" -> (._MoveNext this -1)
345 | | "ShiftTab" -> (._MoveNext this -1)
346 | | "DownArrow" -> (._MoveNext this 1)
347 | | "RightArrow" -> (._MoveNext this 1)
348 | | "Tab" -> (._MoveNext this 1)
349 | | "Action" ->
350 | ; invoke the lambda returned by the button
351 | (val this)
352 | (when (.loop this)
353 | (cls)
354 | (foreach f (.elements this) (.render f))
355 | )
356 |
357 | | "Enter" ->
358 | (.loop this false)
359 | | -> ; ignore other keys
360 | )
361 | )
362 |
363 | ; get all of the field values and return them
364 | (let result {})
365 | (when (.accept this)
366 | (let result {})
367 | (foreach f (.Fields this)
368 | (!! result (.key f) (.CurrentText (.value f)))
369 | )
370 | )
371 | result
372 | )
373 | )
374 |
375 | ;---------------------------------------------------
376 | ;
377 | ; Build some test forms.
378 | ;
379 | ;---------------------------------------------------
380 |
381 | ;
382 | ; A form that's just a stack of buttons
383 | ;
384 | (let optionForm (new ^ConsoleForm "The Menu Form"
385 | | .addBox 15 4 60 20 "Cyan"
386 | | .addLabel 20 6 "The Menu Form: Select an Action then hit Enter."
387 | ;012345678901234567890123456789
388 | | .addButton 30 10 " Turtle Demo " 30
389 | (\ form -> (turtle.tl))
390 | | .addButton 30 12 " Snake Game " 30
391 | (\ form -> (snake.tl))
392 | | .addButton 30 14 " Time and Date " 30
393 | (\ form -> (announce "The time and date are: ${(.datetime/now)}" .consolecolor/cyan))
394 | | .addButton 30 16 " Get BIOS Information " 30
395 | (\ form -> (announce (get-ciminstance 'win32_bios | out-string) .consolecolor/cyan))
396 | | .addButton 30 18 " Tic-Tac-Toe Game " 30
397 | (\ form -> (tictactoe.tl))
398 | | .addButton 30 20 " Exit " 30
399 | (\ form -> (.CancelForm form))
400 | )
401 | )
402 |
403 | ;
404 | ; The main "address" form.
405 | ;
406 | (let addressForm
407 | (new ^ConsoleForm "Address Form"
408 | ;| .addLabel 5 6 (* "=" 90)
409 | | .addBox 3 4 90 20 "Cyan"
410 | | .addLabel 20 5 "Address Information Form 17b"
411 |
412 | | .addlabel 5 10 "First Name:"
413 | | .addfield 20 10 "fn" 25 "" "Help text"
414 |
415 | | .addlabel 50 10 "Last Name:"
416 | | .addfield 65 10 "ln" 25 "" "Help text"
417 |
418 | | .addlabel 5 12 "Address:"
419 | | .addfield 20 12 "ad" 70 "" "Help text"
420 |
421 | | .addlabel 5 14 "City:"
422 | | .addfield 20 14 "ci" 15 "Seattle" "Help text"
423 |
424 | | .addlabel 37 14 "State:"
425 | | .addField 47 14 "st" 15 "Washington" "Help text"
426 |
427 | | .addlabel 65 14 "Country:"
428 | | .addfield 75 14 "cy" 15 "USA" "Help text"
429 |
430 |
431 | ;| .addLabel 5 18 (* "=" 90)
432 |
433 | | .addbutton 20 20 "Accept" 10 (\ form -> (.AcceptForm form))
434 | | .addbutton 35 20 "Options" 10 (\ form -> (.Activate optionForm))
435 | | .addbutton 50 20 "Cancel" 10 (\ form -> (.Cancelform form))
436 | )
437 | )
438 |
439 | (let result (.Activate addressform))
440 |
441 | (println "\n\n\n\n\n")
442 |
443 | result
444 |
445 |
--------------------------------------------------------------------------------
/Examples/tictactoe.tl:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;
3 | ; This script implements a simple Tic-Tac-Toe game
4 | ; in Braid using WinForms. This particular implementation uses
5 | ; types/classes to contain all the logic. These classes derive from
6 | ; and extend existing Windows Forms (Winforms) classes.
7 | ;
8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:
9 |
10 | (using-module winforms)
11 |
12 | (type-alias ^sdc ^system.drawing.color)
13 |
14 | ;-----------------------------------------------------------------
15 | ;
16 | ; A class representing a tile/button in the Tic-Tac-Toe game.
17 | ; This class extends the Winforms button class to add game-specific
18 | ; features
19 | ;
20 | (deftype ^ticTacToeButton -extends: ^System.Windows.Forms.Button
21 |
22 | ;-----------------------------------------------------------------
23 | ;
24 | ; initialize this instance
25 | ;
26 | :defm new (fn this buttonNumber ->
27 | (this
28 | | .Size (wf/Size 75 75)
29 | | .Font (wf/font "Courier New" 18)
30 | | .TabIndex buttonNumber
31 | | .reset buttonNumber ; call the reset method to finish the initialization.
32 | )
33 |
34 | ; bind the click event handler for the button. This handles all of the business
35 | ; logic for:
36 | ; - making X's move
37 | ; - checking the board for wins or cat's games.
38 | ; - making the computer's moves
39 | ; - checking again for wins or cat's games
40 | (.add_Click this
41 | (aseventhandler
42 | (fn this x ->
43 |
44 | ; check to see if there are no moves left
45 | (if (.CatsGame mainform) (return))
46 |
47 | ; perform X's move.
48 | (.mark this "X")
49 | (when (.CheckWin mainform "X")
50 | (let result
51 | (wf/messagebox
52 | "\n\tCongradulations!\n\t\tYou WIN!!!\n\n\nDo you want to play again?"
53 | "Question" "okcancel"
54 | )
55 | )
56 |
57 | (if (== result "OK")
58 | (.newGame mainform)
59 | (.close mainform)
60 | )
61 |
62 | (return)
63 | )
64 |
65 | ; check again - it could be a cat's game now.
66 | (if (.CatsGame mainform) (return))
67 |
68 | ; Make the computer's move
69 | (.ComputersMove mainform)
70 | (when (.CheckWin mainform "O")
71 | (let result (wf/messagebox
72 | "\nToo bad!\n\tYOU LOST :-(\n\n\nDo you want to play again?"
73 | "Question" "okcancel"))
74 |
75 | (if (== result "OK")
76 | (.newGame mainform)
77 | (.Close MainForm)
78 | )
79 |
80 | (return)
81 | )
82 |
83 | ; and one more check for tied games.
84 | (.CatsGame mainform)
85 | )
86 | )
87 | )
88 | )
89 |
90 | ;-----------------------------------------------------------------
91 | ;
92 | ; Reset the button to its default state
93 | ;
94 | :defm Reset (fn this (^string buttonNumber) ->
95 | (this
96 | | .Text buttonNumber
97 | | .BackColor .sdc/Gray
98 | | .ForeColor .sdc/white
99 | | .Enabled true
100 | )
101 | )
102 |
103 | ;-----------------------------------------------------------------
104 | ;
105 | ; A method to mark the button as being owned by either X or O
106 | ;
107 | :defm Mark (fn this player ->
108 | (this
109 | | .Text player
110 | | .ForeColor .sdc/black
111 | | .BackColor (if (== player "X") .sdc/cyan .sdc/lightyellow)
112 | | .Enabled false
113 | )
114 | )
115 |
116 | ;-----------------------------------------------------------------
117 | ;
118 | ; See how this button has been marked if at all
119 | ;
120 | :defm GetMark (fn this ->
121 | (let btext (.text this))
122 | (if (contains? "XO" btext)
123 | btext ; button has been claimed by a player
124 | ; otherwise
125 | " " ; the button is unclaimed so return space
126 | )
127 | )
128 | )
129 |
130 | ;-----------------------------------------------------------------
131 | ;
132 | ; This class models the game board and manages all the buttons.
133 | ; It derives from Winforms ^Form class.
134 | ;
135 | (deftype ^tictactoe -extends: ^System.Windows.Forms.Form
136 |
137 | ; Member variables holding the move tables.
138 | ^Vector winningMoves
139 | ^IDictionary WinningMovesToTry
140 | ^IDictionary BlockingMovesToTry
141 | ^IDictionary StrategicMovesToTry
142 |
143 | ;-----------------------------------------------------------------
144 | ;
145 | ; the board constructor initializes the board and creates all the buttons.
146 | ;
147 | :defm new (fn this ->
148 |
149 | ;
150 | ; Any of the sequences of tiles in this vector represents a winning move.
151 | ;
152 | (.winningMoves this [
153 | [0 1 2]
154 | [3 4 5]
155 | [6 7 8]
156 | [0 3 6]
157 | [1 4 7]
158 | [2 5 8]
159 | [0 4 8]
160 | [2 4 6]
161 | ]
162 | )
163 |
164 | ;
165 | ; Build a dictionary of winning moves to try. The key contains
166 | ; the pattern to check while the value is where to make the
167 | ; next move.
168 | ;
169 | (.WinningMovesToTry this {
170 | ;012345678
171 | "OO ......" 2
172 | "O O......" 1
173 | " OO......" 0
174 | "...OO ..." 5
175 | "...O O..." 4
176 | "... OO..." 3
177 | "......OO " 8
178 | "......O O" 7
179 | "...... OO" 6
180 | " ...O...O" 0
181 | "O... ...O" 4
182 | "O...O... " 8
183 | "..O. .O.." 4
184 | ".. .O.O.." 2
185 | "..O.O. .." 6
186 | "O..O.. .." 6
187 | "O.. ..O.." 3
188 | " ..O..O.." 0
189 | ".O..O.. ." 7
190 | ".O.. ..O." 4
191 | ". ..O..O." 1
192 | "..O..O.. " 8
193 | "..O.. ..O" 5
194 | ".. ..O..O" 2
195 | }
196 | )
197 |
198 | ;
199 | ; Build the blocking move table. It's identical to the winning move
200 | ; table except with X instead of O
201 | ;
202 | (.BlockingMovesToTry this {})
203 | (foreach key (.WinningMovesToTry this | .keys)
204 | (let newKey (re/replace key "O" "X"))
205 | (!! (.BlockingMovesToTry this) newkey (!! (.WinningMovesToTry this) key))
206 | )
207 |
208 | ;
209 | ; Defines the best move to make when all other things are equal.
210 | ;
211 | (.StrategicMovesToTry this {
212 | ;012
213 | ;345
214 | ;678
215 | (str ".X."
216 | "..X"
217 | "...") 2
218 | (str ".X."
219 | "X.."
220 | "...") 0
221 | (str "..."
222 | "..X"
223 | ".X.") 8
224 | (str "..."
225 | "X.."
226 | ".X.") 6
227 | ;012345678
228 | "X ......." 1
229 | " .X......" 0
230 | "....... X" 7
231 | "......X ." 7
232 | ".... ...." 4
233 | }
234 | )
235 |
236 | ;
237 | ; Some layout utility routines
238 | ;
239 | (defn rightedge [control offset] (.right control | + offset))
240 | (defn bottomEdge [control offset] (.bottom control | + offset))
241 |
242 | (let xPos 12)
243 | (let yPos 30)
244 | (let lastcontrol nil)
245 |
246 | ; create and add all of the button controls
247 | (forall buttonNumber (range 9)
248 | (let button (new ^ticTacToeButton buttonNumber))
249 | (.Location button (wf/Point xPos yPos))
250 | (let xPos (rightEdge button 12))
251 | (let lastControl button)
252 | (when (% buttonNumber 3 | == 0)
253 | (let xPos 12)
254 | (let yPos (bottomEdge lastControl 12))
255 | )
256 | (.controls this | .add button)
257 | )
258 |
259 | ;
260 | ; now configure the rest of this form...
261 | ;
262 | (this
263 | | .Text "Tic-Tac-Toe"
264 | | .StartPosition .System.Windows.Forms.FormStartPosition/centerscreen
265 | | .BackColor .sdc/gray
266 | | .add_Shown (aseventhandler (fn e o -> (.Activate this)))
267 | )
268 |
269 | ; Add the menus
270 | (wf/menustrip this [
271 | (wf/menu "File" [
272 | (wf/menuitem "New Game" (fn e o -> (.NewGame this)))
273 | ;(wf/separator)
274 | (wf/menuitem "Quit" (fn e o -> (.Close this)))
275 | ]
276 | )
277 | ]
278 | )
279 |
280 | ; Finally adjust the size of the containing form to just wrap the buttons.
281 | (.ClientSize this
282 | (wf/Size
283 | (RightEdge lastControl 12)
284 | (BottomEdge lastControl 12)
285 | )
286 | )
287 | )
288 |
289 | ;-----------------------------------------------------------------
290 | ;
291 | ; A method to start the game; this is really the only end-user method
292 | ;
293 | :defm Play (fn ^void this -> (.showdialog this))
294 |
295 | ;-----------------------------------------------------------------
296 | ;
297 | ; Method to reset the game board...
298 | ;
299 | :defm NewGame (fn this ->
300 | (let buttonNumber 1)
301 | (foreach button (.controls this | filter ^ticTacToeButton)
302 | (.reset button (pincr buttonNumber))))
303 |
304 | ;-----------------------------------------------------------------
305 | ;
306 | ; Gets the board state as a simple string so it can
307 | ; be matched against the move tables.
308 | ;
309 | :defm getBoardAsString (fn this ->
310 | (.controls this | filter ^ticTacToeButton | map .getMark | join ""))
311 |
312 | ;-----------------------------------------------------------------
313 | ;
314 | ; Check for a cat's game (no winner). This is
315 | ; when there are no open spaces left on the board
316 | ; but there is no winning sequence.
317 | ;
318 | :defm CatsGame (fn this ->
319 | (if (not (contains? (.getBoardAsString this) " "))
320 | (do
321 | (wf/messagebox "\n\n\t\tCats Game!\n\n\tClick OK for a new game.\n")
322 | (.NewGame this)
323 | true
324 | )
325 | false
326 | )
327 | )
328 |
329 | ;-----------------------------------------------------------------
330 | ;
331 | ; Check to see if anybody won...
332 | ;
333 | :defm CheckWin (fn this player ->
334 | (let buttons (.controls this | filter ^ticTacToeButton))
335 | (foreach move (.winningMoves this)
336 | (let win true)
337 | (foreach index move
338 | (if (not (re/match (.Text (!! buttons index)) player))
339 | (do
340 | (let win false)
341 | (break)
342 | )
343 | )
344 | )
345 |
346 | (when win
347 | ;
348 | ; Blink the winning row for a while
349 | ; then leave it marked...
350 | ;
351 | (let fg
352 | (if (== player 'x')
353 | (.sdc/green)
354 | (.sdc/red)
355 | )
356 | )
357 |
358 | (let bg .sdc/gray)
359 |
360 | ; blink the winning buttons
361 | (repeat 7
362 | (foreach index move
363 | (.BackColor (!! buttons index) fg)
364 | (.ForeColor (!! buttons index) bg)
365 | )
366 |
367 | (.update this)
368 | (sleep 200)
369 | ; swap the colors
370 | (swap fg bg)
371 | )
372 |
373 | ;
374 | ; Disable the remaining buttons so no more play happens...
375 | ;
376 | (foreach button buttons
377 | (.enabled button false)
378 | )
379 |
380 | (return true)
381 | )
382 | )
383 |
384 | false
385 | )
386 |
387 | ;-----------------------------------------------------------------
388 | ;
389 | ; A method that implements the computer move strategy
390 | ;
391 | :defm ComputersMove (fn this ->
392 |
393 | (let board (.GetBoardAsString this))
394 | (let buttons (.controls this | filter ^ticTacToeButton))
395 |
396 | ; look for potential wins first...
397 | (foreach e (.WinningMovesToTry this)
398 | (when (re/match board (.key e))
399 | (.mark (!! buttons (.value e)) "O")
400 | (return)
401 | )
402 | )
403 |
404 | ; Check blocking moves next...
405 | (foreach e (.BlockingMovesToTry this)
406 | (when (re/match board (.key e))
407 | (.mark (!! buttons (.value e)) "O")
408 | (return)
409 | )
410 | )
411 |
412 | ; Check strategic moves next...
413 | (foreach e (.StrategicMovesToTry this)
414 | (when (re/match board (.key e))
415 | (.mark (!! buttons (.value e)) "O")
416 | (return)
417 | )
418 | )
419 |
420 | ; Otherwise just pick a move at random...
421 | (let limit 100)
422 | (while (decr limit)
423 | (let move (random 1 0 8))
424 | (when (re/match (!! board move) " ")
425 | (.mark (!! buttons move) "O")
426 | (return)
427 | )
428 | )
429 |
430 | (wf/messagebox "ERROR - no valid move found!")
431 | )
432 | )
433 |
434 | ;-----------------------------------------------------------------
435 | ;
436 | ; And finally create a game instance and start it...
437 | ;
438 | (let mainform (new ^tictactoe))
439 | (.play mainform)
440 |
441 |
--------------------------------------------------------------------------------
/src/utils.cs:
--------------------------------------------------------------------------------
1 | /////////////////////////////////////////////////////////////////////////////
2 | //
3 | // The Braid Programming Language - Utility functions for the interpreter
4 | //
5 | //
6 | // Copyright (c) 2023 Bruce Payette (see LICENCE file)
7 | //
8 | ////////////////////////////////////////////////////////////////////////////
9 |
10 | using System;
11 | using System.Linq;
12 | using System.Numerics;
13 | using System.Collections;
14 | using System.Text;
15 | using System.Text.RegularExpressions;
16 | using System.Collections.Generic;
17 | using System.IO;
18 |
19 | namespace BraidLang
20 | {
21 | ///
22 | /// Utility functions for braid.
23 | ///
24 | public static class Utils
25 | {
26 | // Used by the following routines for indenting the text being printed.
27 | public static string textoffset = string.Empty;
28 |
29 | ///
30 | /// Returns the source string representation of an object. Strings are
31 | /// returned with escapes sequences, doubles will always have a decimal point,
32 | /// dictionaries will be represented as dictionary literals, etc.
33 | ///
34 | /// The object to stringize
35 | /// The source string representation of the object.
36 | public static string ToSourceString(object obj)
37 | {
38 | if (obj == null)
39 | {
40 | return "nil";
41 | }
42 |
43 | if (Utils.textoffset.Length > 1000)
44 | {
45 | Utils.textoffset = string.Empty;
46 | Braid.BraidRuntimeException($"ToSourceString is too deeply nested; current object is type ^{obj.GetType()}");
47 | }
48 |
49 | switch (obj)
50 | {
51 | case double d:
52 | // Added a trailing ".0" to a string with no decimal point so it will reparse as a decimal.
53 | string sd = d.ToString();
54 | if (!sd.Contains('.'))
55 | {
56 | sd += ".0";
57 | }
58 |
59 | return sd;
60 |
61 | case Callable cb:
62 | if (string.Equals(cb.Name, "lambda", StringComparison.OrdinalIgnoreCase))
63 | {
64 | // Anonymous function
65 | return cb.ToString();
66 | }
67 | else
68 | {
69 | // Named function
70 | return cb.Name;
71 | }
72 |
73 | case IDictionary dict:
74 | return ToStringDict(dict);
75 |
76 | case HashSet