1: #if INTERACTIVE
  2: #else
  3: namespace global
  4: #endif
  5: 
  6: type UnitType = 
  7:     | Empty
  8:     | Unit of string * int 
  9:     | CompositeUnit of UnitType list     
 10:     static member Create(s,n) =
 11:         if n = 0 then Empty else Unit(s,n)
 12:     override this.ToString() =
 13:         let exponent = function
 14:             | Empty -> 0
 15:             | Unit(_,n) -> n
 16:             | CompositeUnit(_) -> invalidOp ""
 17:         let rec toString = function        
 18:             | Empty -> ""
 19:             | Unit(s,n) when n=0 -> ""
 20:             | Unit(s,n) when n=1 -> s
 21:             | Unit(s,n)          -> s + " ^ " + n.ToString()            
 22:             | CompositeUnit(us) ->               
 23:                 let ps, ns =
 24:                     us |> List.partition (fun u -> exponent u >= 0)
 25:                 let join xs = 
 26:                     let s = xs |> List.map toString |> List.toArray             
 27:                     System.String.Join(" ",s)
 28:                 match ps,ns with
 29:                 | ps, [] -> join ps
 30:                 | ps, ns ->
 31:                     let ns = ns |> List.map UnitType.Reciprocal
 32:                     join ps + " / " + join ns
 33:         match this with
 34:         | Unit(_,n) when n < 0 -> " / " + (this |> UnitType.Reciprocal |> toString)
 35:         | _ -> toString this    
 36:     static member ( * ) (v:ValueType,u:UnitType) = UnitValue(v,u)    
 37:     static member ( * ) (lhs:UnitType,rhs:UnitType) =       
 38:         let text = function
 39:             | Empty -> ""                 
 40:             | Unit(s,n) -> s
 41:             | CompositeUnit(us) -> us.ToString()
 42:         let normalize us u =
 43:             let t = text u
 44:             match us |> List.tryFind (fun x -> text x = t), u with
 45:             | Some(Unit(s,n) as v), Unit(_,n') ->
 46:                 us |> List.map (fun x -> if x = v then UnitType.Create(s,n+n') else x)                 
 47:             | Some(_), _ -> raise (new System.NotImplementedException())
 48:             | None, _ -> us@[u]
 49:         let normalize' us us' =
 50:             us' |> List.fold (fun (acc) x -> normalize acc x) us
 51:         match lhs,rhs with
 52:         | Unit(u1,p1), Unit(u2,p2) when u1 = u2 ->
 53:             UnitType.Create(u1,p1+p2)
 54:         | Empty, _ -> rhs
 55:         | _, Empty -> lhs 
 56:         | Unit(u1,p1), Unit(u2,p2) ->            
 57:             CompositeUnit([lhs;rhs])
 58:         | CompositeUnit(us), Unit(_,_) ->
 59:             CompositeUnit(normalize us rhs)
 60:         | Unit(_,_), CompositeUnit(us) ->
 61:             CompositeUnit(normalize' [lhs]  us)
 62:         | CompositeUnit(us), CompositeUnit(us') ->
 63:             CompositeUnit(normalize' us us')
 64:         | _,_ -> raise (new System.NotImplementedException())
 65:     static member Reciprocal x =
 66:         let rec reciprocal = function
 67:             | Empty -> Empty
 68:             | Unit(s,n) -> Unit(s,-n)
 69:             | CompositeUnit(us) -> CompositeUnit(us |> List.map reciprocal)
 70:         reciprocal x
 71:     static member ( / ) (lhs:UnitType,rhs:UnitType) =        
 72:         lhs * (UnitType.Reciprocal rhs)
 73:     static member ( + ) (lhs:UnitType,rhs:UnitType) =       
 74:         if lhs = rhs then lhs                
 75:         else invalidOp "Unit mismatch"   
 76: and ValueType = decimal
 77: and UnitValue (v:ValueType,u:UnitType) =
 78:     new(v:ValueType) = UnitValue(v,Empty)
 79:     new(v:ValueType,s:string) = UnitValue(v,Unit(s,1))
 80:     member this.Value = v
 81:     member this.Unit = u
 82:     override this.ToString() = sprintf "%O %O" v u
 83:     static member (~-) (v:UnitValue) =
 84:         UnitValue(-v.Value,v.Unit)
 85:     static member (+) (lhs:UnitValue,rhs:UnitValue) =
 86:         UnitValue(lhs.Value+rhs.Value, lhs.Unit+rhs.Unit)         
 87:     static member (-) (lhs:UnitValue,rhs:UnitValue) =
 88:         UnitValue(lhs.Value-rhs.Value, lhs.Unit+rhs.Unit) 
 89:     static member (*) (lhs:UnitValue,rhs:UnitValue) =                    
 90:         UnitValue(lhs.Value*rhs.Value,lhs.Unit*rhs.Unit)                
 91:     static member (*) (lhs:UnitValue,rhs:ValueType) =        
 92:         UnitValue(lhs.Value*rhs,lhs.Unit)      
 93:     static member (*) (v:UnitValue,u:UnitType) = 
 94:         UnitValue(v.Value,v.Unit*u)  
 95:     static member (/) (lhs:UnitValue,rhs:UnitValue) =                    
 96:         UnitValue(lhs.Value/rhs.Value,lhs.Unit/rhs.Unit)
 97:     static member (/) (lhs:UnitValue,rhs:ValueType) =
 98:         UnitValue(lhs.Value/rhs,lhs.Unit)  
 99:     static member (/) (v:UnitValue,u:UnitType) =
100:         UnitValue(v.Value,v.Unit/u)
101:     static member Pow (lhs:UnitValue,rhs:UnitValue) =
102:         let isInt x = 0.0M = x - (x |> int |> decimal)
103:         let areAllInts =
104:             List.forall (function (Unit(_,p)) -> isInt (decimal p*rhs.Value) | _ -> false)      
105:         let toInts =            
106:             List.map (function (Unit(s,p)) -> Unit(s, int (decimal p * rhs.Value)) | _ -> invalidOp "" )
107:         match lhs.Unit, rhs.Unit with
108:         | Empty, Empty -> 
109:             let x = (float lhs.Value) ** (float rhs.Value)           
110:             UnitValue(decimal x)
111:         | _, Empty when isInt rhs.Value ->
112:             pown lhs (int rhs.Value)
113:         | Unit(s,p1), Empty when isInt (decimal p1*rhs.Value) ->
114:             let x = (float lhs.Value) ** (float rhs.Value)
115:             UnitValue(x |> decimal, Unit(s,int (decimal p1*rhs.Value)))       
116:         | CompositeUnit us, Empty when areAllInts us -> 
117:             let x = (float lhs.Value) ** (float rhs.Value)
118:             UnitValue(x |> decimal, CompositeUnit(toInts us))
119:         | _ -> invalidOp "Unit mismatch"
120:     static member One = UnitValue(1.0M,Empty) 
121:     override this.Equals(that) =
122:         let that = that :?> UnitValue
123:         this.Unit = that.Unit && this.Value = that.Value
124:     override this.GetHashCode() = hash this 
125:     interface System.IComparable with
126:         member this.CompareTo(that) =
127:             let that = that :?> UnitValue
128:             if this.Unit = that.Unit then
129:                 if this.Value < that.Value then -1
130:                 elif this.Value > that.Value then 1
131:                 else 0
132:             else invalidOp "Unit mismatch"
133: 
134: [<AutoOpen>]
135: module Tokenizer =
136: 
137:     type token =
138:         | WhiteSpace
139:         | Symbol of char
140:         | OpToken of string
141:         | StrToken of string
142:         | NumToken of string
143: 
144:     let (|Match|_|) pattern input =
145:         let m = System.Text.RegularExpressions.Regex.Match(input, pattern)
146:         if m.Success then Some m.Value else None
147: 
148:     let matchToken = function
149:         | Match @"^\s+" s -> s, WhiteSpace
150:         | Match @"^\+|^\-|^\*|^\/|^\^"  s -> s, OpToken s
151:         | Match @"^=|^<>|^<=|^>=|^>|^<"  s -> s, OpToken s   
152:         | Match @"^\(|^\)|^\,|^\:" s -> s, Symbol s.[0]
153:         | Match @"^[A-Za-z]+" s -> s, StrToken s
154:         | Match @"^\d+(\.\d+)?|\.\d+" s -> s, s |> NumToken
155:         | _ -> invalidOp "Failed to match token"
156: 
157:     let tokenize s =
158:         let rec tokenize' index (s:string) =
159:             if index = s.Length then [] 
160:             else
161:                 let next = s.Substring index 
162:                 let text, token = matchToken next
163:                 token :: tokenize' (index + text.Length) s
164:         tokenize' 0 s
165:         |> List.choose (function WhiteSpace -> None | t -> Some t)
166: 
167: [<AutoOpen>]
168: module Parser =
169: 
170:     type arithmeticOp = Add | Sub | Mul | Div
171:     type formula =
172:         | Neg of formula
173:         | Exp of formula * formula
174:         | ArithmeticOp of formula * arithmeticOp * formula
175:         | Num of UnitValue
176: 
177:     let rec (|Term|_|) = function
178:         | Exponent(f1, t) ->      
179:             let rec aux f1 = function        
180:                 | SumOp op::Exponent(f2, t) -> aux (ArithmeticOp(f1,op,f2)) t               
181:                 | t -> Some(f1, t)      
182:             aux f1 t  
183:         | _ -> None
184:     and (|SumOp|_|) = function 
185:         | OpToken "+" -> Some Add | OpToken "-" -> Some Sub 
186:         | _ -> None
187:     and (|Exponent|_|) = function
188:         | Factor(b, OpToken "^"::Exponent(e,t)) -> Some(Exp(b,e),t)
189:         | Factor(f,t) -> Some (f,t)
190:         | _ -> None
191:     and (|Factor|_|) = function  
192:         | OpToken "-"::Factor(f, t) -> Some(Neg f, t)
193:         | Atom(f1, ProductOp op::Factor(f2, t)) ->
194:             Some(ArithmeticOp(f1,op,f2), t)       
195:         | Atom(f, t) -> Some(f, t)  
196:         | _ -> None    
197:     and (|ProductOp|_|) = function
198:         | OpToken "*" -> Some Mul | OpToken "/" -> Some Div
199:         | _ -> None
200:     and (|Atom|_|) = function    
201:         | Symbol '('::Term(f, Symbol ')'::t) -> Some(f, t)
202:         | Number(n,t) -> Some(n,t)
203:         | Units(u,t) -> Some(Num u,t)  
204:         | _ -> None
205:     and (|Number|_|) = function
206:         | NumToken n::Units(u,t) -> Some(Num(u * decimal n),t)
207:         | NumToken n::t -> Some(Num(UnitValue(decimal n)), t)      
208:         | _ -> None
209:     and (|Units|_|) = function
210:         | Unit'(u,t) ->
211:             let rec aux u1 =  function
212:                 | OpToken "/"::Unit'(u2,t) -> aux (u1 / u2) t
213:                 | Unit'(u2,t) -> aux (u1 * u2) t
214:                 | t -> Some(u1,t)
215:             aux u t
216:         | _ -> None
217:     and (|Int|_|) s = 
218:         match System.Int32.TryParse(s) with
219:         | true, n -> Some n
220:         | false,_ -> None
221:     and (|Unit'|_|) = function  
222:         | StrToken u::OpToken "^"::OpToken "-"::NumToken(Int p)::t -> 
223:             Some(UnitValue(1.0M,UnitType.Create(u,-p)),t)  
224:         | StrToken u::OpToken "^"::NumToken(Int p)::t -> 
225:             Some(UnitValue(1.0M,UnitType.Create(u,p)),t)
226:         | StrToken u::t ->
227:             Some(UnitValue(1.0M,u), t)
228:         | _ -> None
229: 
230:     let parse s = 
231:         match tokenize s with
232:         | Term(f,[]) -> f 
233:         | _ -> failwith "Failed to parse formula"
234: 
235:     let evaluate formula =
236:         let rec eval = function
237:             | Neg f -> - (eval f)
238:             | Exp(b,e) -> (eval b) ** (eval e)
239:             | ArithmeticOp(f1,op,f2) -> arithmetic op (eval f1) (eval f2)        
240:             | Num d -> d
241:         and arithmetic = function
242:             | Add -> (+) | Sub -> (-) | Mul -> (*) | Div -> (/)      
243:         eval formula
244: 
245: open System.Windows
246: open System.Windows.Controls
247: open System.Windows.Input
248: open System.Windows.Media
249: 
250: [<AutoOpen>]
251: module Collection =
252:     let toDoubleCollection xs =
253:         let collection = DoubleCollection()
254:         xs |> Seq.iter collection.Add
255:         collection
256: 
257: [<AutoOpen>]
258: module Resources =
259:     open System.Windows.Shapes
260: 
261:     let createBorder color =
262:         Rectangle(
263:             Stretch=Stretch.Fill,
264:             RadiusX=6.0,
265:             RadiusY=6.0,
266:             Stroke=SolidColorBrush(color),
267:             StrokeThickness=6.0,
268:             StrokeLineJoin=PenLineJoin.Round
269:         )
270: 
271:     let createDashedBorder color =
272:         let border = createBorder color
273:         border.StrokeDashCap <- PenLineCap.Round
274:         border.StrokeDashArray <- [4.0;3.0] |> toDoubleCollection
275:         border        
276: 
277: type Calculator () as this =
278:     inherit UserControl ()
279:     
280:     let label = 
281:         TextBlock(
282:             Text="Formula Calculator",
283:             Foreground=SolidColorBrush(Colors.Purple),
284:             FontWeight=FontWeights.Bold,
285:             FontSize=18.0,
286:             Margin=Thickness(8.0,8.0,8.0,0.0),
287:             HorizontalAlignment=HorizontalAlignment.Center
288:         )
289:     
290:     let formulaText = 
291:         TextBox(Text="Enter Formula Here",
292:                 BorderThickness=Thickness(0.0),
293:                 Margin=Thickness(8.0),                               
294:                 SelectionBackground=SolidColorBrush(Colors.Gray),
295:                 SelectionForeground=SolidColorBrush(Colors.White)
296:         )
297: 
298:     let makeBorder parent child =
299:         let border = Grid()
300:         do  border.Children.Add parent
301:         do  border.Children.Add child
302:         border
303: 
304:     let (+.) (panel:#Panel) (item) =
305:         panel.Children.Add item |> ignore; panel
306: 
307:     let (+@) (grid:Grid) (item,col,row) =
308:         grid.Children.Add item
309:         Grid.SetColumn(item,col)
310:         Grid.SetRow(item,row)
311:         grid
312: 
313:     let computeButton = 
314:         Button(Content=" = ",
315:                Margin=Thickness(8.0),
316:                HorizontalAlignment=HorizontalAlignment.Right
317:         )
318: 
319:     let formulaPanel =        
320:         Grid()
321:             +@ (formulaText,0,0)
322:             +@ (computeButton,1,0)    
323:     do  [GridLength(); GridLength(1.0,GridUnitType.Star)]
324:         |> List.iter (fun x -> 
325:             ColumnDefinition(Width=x) 
326:             |> formulaPanel.ColumnDefinitions.Add
327:         )
328: 
329:     let dashedBorder = createDashedBorder Colors.Red
330:     let formulaPanel = makeBorder dashedBorder formulaPanel
331:     do  formulaPanel.Margin <- Thickness(8.0)
332: 
333:     let resultBlock = 
334:         TextBlock(Text="Result",Margin=Thickness(12.0))
335:     let resultPanel =
336:         resultBlock |> makeBorder (createBorder Colors.Blue)
337:     do  resultPanel.Margin <- Thickness(8.0)
338: 
339:     let solidBorder = createBorder Colors.Magenta
340:     let layout =
341:         StackPanel() 
342:             +. label 
343:             +. formulaPanel
344:             +. resultPanel
345:         |> makeBorder solidBorder
346:     
347:     let compute _ =
348:         try
349:         parse formulaText.Text
350:         |> evaluate
351:         |> sprintf "%O"
352:         with e -> e.Message
353:         |> (fun s -> resultBlock.Text <- s)
354: 
355:     do  formulaText.KeyDown.Add (fun e ->
356:             if e.Key = Key.Enter
357:             then compute ()
358:         )
359:     do  computeButton.Click.Add compute
360:     do  this.Content <- layout
361: 
362: #if INTERACTIVE
363: open Microsoft.TryFSharp
364: App.Dispatch (fun() -> 
365:     App.Console.ClearCanvas()
366:     Calculator() |> App.Console.Canvas.Children.Add
367:     App.Console.CanvasPosition <- CanvasPosition.Right
368: )
369: #endif