Merge pull request #86 from el2724/ed_binop

Ed binop

lib/std.nh

@@ -8,60 +8,121 @@ extern "support.hpp" "std" "to_string" fun StringOfInt int -> string
 
 extern "support.hpp" "std" "pow" fun Pow float float -> float
 
+/*
+
+type key_signature = {
+  scale = { 261.63, 293.66, 329.63, 349.23, 392.00, 440.00, 493.88 }
+}
+
+type time_signature = {
+  upper = 4
+  lower = 4
+}
+
+type pitch = {
+  rank = 1
+  octave = 0
+  offset = 0
+}
+
+type chord = {
+  pitches = pitch[]
+}
+
+type track = {
+  key_signature = init key_signature
+  time_signature = init time_signature
+  chords = chord[]
+  durations = float[]
+}
+
+fun IsMember l x = (
+  b = false
+  for item in l
+    do b = b || (item == x)
+  b
+)
+fun ChordOfPitch pitch = init chord { pitches = [pitch] }
+fun PitchOfInt i = init pitch { rank = i }
+fun AddPitchOctave pitch octaves = ( pitch$octave = pitch$octave + octaves; pitch )
+fun FlatPitch pitch = ( pitch$offset = pitch$offset - 1; pitch )
+fun SharpPitch pitch = ( pitch$offset = pitch$offset + 1; pitch )
+fun ChordOfChords c1 c2 = (
+  c = chord[]
+  for pitch in c1$pitches . c2$pitches
+    do if IsMember c pitch then () else (c = c . [pitch]; ())
+  c
+)
+
+fun Rest = init chord
+
+fun ConcatTracks t1 t2 = {
+  if t1$key_signature == t2$key_signature &&
+      t1$time_signature == t2$time_signature
+  then (
+    t1$chords = t1$chords . t2$chords
+    t1$durations = t1$durations . t2$durations
+    t1
+  )
+  else throw "Cannot concat tracks with different key or time signature"
+}
+
 fun PrintEndline str = (
   Print str
   Print "\n"
 )
 
-/*
+*/
 
-include std_basic
+
+
+/*
 
 key_signature = init key_signature
 time_signature = init time_signature
 tempo = 120
 
 
 fun Scale pitch_start pitch_end = (
-	// TODO: interpolate between pitches
+  // TODO: interpolate between pitches
 )
 
 
 fun Arpeggio chord = (
-	// TODO: unpack chord into music array
+  // TODO: unpack chord into music array
 )
 
 
 fun Rhythm track = (
-	// TODO: get rhythm from track
+  // TODO: get rhythm from track
 )
 
 
 fun Chords track = (
-	// TODO: get chords from track
+  // TODO: get chords from track
 )
 
 
 // TODO: unlimited args option
 fun Parallel *tracks = (
-	// TODO: return song object with tracks aligned in parallel
+  // TODO: return song object with tracks aligned in parallel
 )
 
 
 fun Sequential *tracks = (
-	// TODO: return song object with tracks aligned sequentially
+  // TODO: return song object with tracks aligned sequentially
 )
 
 fun Length track = (
-	// TODO: return length of track in terms of duration
+  // TODO: return length of track in terms of duration
 )
 
 fun Extend length track = (
-	// TODO: repeat track for up to length duration
+  // TODO: repeat track for up to length duration
 )
 
 fun StartWith track base_track = (
-	
+  
 )
 
 fun EndWith track base_track = (

src/ast.ml

@@ -37,7 +37,7 @@ type expr =
   | Block of expr list
   | Conditional of expr * expr * expr
   | For of string * expr * expr
-  | Throw of expr * expr
+  | Throw of expr
   | Assign of var_reference * expr
   | StructInit of string * expr list
 
@@ -102,7 +102,7 @@ let rec string_of_expr e =
   | ArrIdx (x, y) -> String.concat " " [ x; ".("; string_of_expr y; ")" ]
   | Arr(x) -> String.concat " " [ "["; string_of_exp_list x; "]" ]
   | ArrMusic(x) -> String.concat " " [ "{"; string_of_exp_list x; "}" ]
-  | Throw(x, y) -> String.concat " " ["Throw"; string_of_expr x; string_of_expr y]
+  | Throw(x) -> String.concat " " ["Throw"; string_of_expr x]
 and string_of_exp_list l =
   match l with
   | [] -> ""

src/cast.ml

@@ -2,7 +2,7 @@ open Core.Std
 
 open Ast
 
-type binary_operator = Add | Sub | Mult | Div | Equal | Neq | Less | Leq | Greater | Geq
+type binary_operator = Add | Sub | Mult | Div | Mod | Equal | Neq | Less | Leq | And | Or
 type unary_operator = Not | Neg
 
 type decl = Ast.t * string
@@ -91,7 +91,7 @@ let rec string_of_expr = function
       (match o with
       | Add -> "+" | Sub -> "-" | Mult -> "*" | Div -> "/"
       | Equal -> "==" | Neq -> "!="
-      | Less -> "<" | Leq -> "<=" | Greater -> ">" | Geq -> ">=") ^ " " ^
+      | Less -> "<" | Leq -> "<=" | Mod -> "%" | And -> "&&" | Or -> "||") ^ " " ^
       string_of_expr e2
   | Uniop(o, e) -> (match o with Not -> "!" | Neg -> "-") ^ string_of_expr e
   | Assign(v, e) -> string_of_expr (VarRef(v)) ^ " = " ^ string_of_expr e

src/cpp_sast.ml

@@ -14,11 +14,37 @@ let rec castx_of_sastx texpr =
     | Sast.LitStr(x) -> Cast.LitStr(x)
     | Sast.LitUnit -> Cast.LitUnit
 
-    | Sast.Binop(lexpr, op, rexpr)
-        -> ignore lexpr; ignore op; ignore rexpr; failwith "Binop cast_sast not implemented"
+    | Sast.Binop(lexpr, op, rexpr) ->
+        begin match op with
+          | Ast.Zip -> failwith "Internal error: binop zip should have been converted to Call NhFunction in ast2sast"
+          | Ast.Concat ->
+              Cast.Call(Cast.Function("nh_support","concat"),[castx_of_sastx lexpr; castx_of_sastx rexpr])
+          | Ast.Chord -> failwith "Internal error: binop chord should have been converted to Call NhFunction in ast2sast"
+          | Ast.Octave -> failwith "Internal error: binop octave should have been converted to Call NhFunction in ast2sast"
+          | _ as cop -> let op = begin match cop with
+            | Ast.Add -> Cast.Add
+            | Ast.Sub -> Cast.Sub
+            | Ast.Mul -> Cast.Mult
+            | Ast.Div -> Cast.Div
+            | Ast.Mod -> Cast.Mod
+            | Ast.Eq -> Cast.Equal
+            | Ast.Neq -> Cast.Neq
+            | Ast.Lt -> Cast.Less
+            | Ast.Lte -> Cast.Leq
+            | Ast.And -> Cast.And
+            | Ast.Or -> Cast.Or
+            | _ -> failwith "Internal error: failed to match all possible binops in sast2cast"
+          end in Cast.Binop(castx_of_sastx lexpr, op, castx_of_sastx rexpr)
+        end
+
 
-    | Sast.Uniop(op, expr)
-        -> ignore op; ignore expr; failwith "Uniop cast_sast not implemented"
+    | Sast.Uniop(op, expr) ->
+        begin match op with
+          | Ast.Not -> Cast.Uniop(Cast.Not, castx_of_sastx expr)
+          | Ast.Neg -> Cast.Uniop(Cast.Neg, castx_of_sastx expr)
+          | _ -> failwith
+              "Internal error: uniop flat and sharp should have been converted to Call NhFunction in ast2sast"
+        end
 
     | Sast.VarRef(names) -> Cast.VarRef(names)
 

src/parser.mly

@@ -143,7 +143,7 @@ expr:
 | expr CONCAT expr { Binop($1, Concat, $3) }
 | ID_VAR DOT_LPAREN expr RPAREN { ArrIdx($1, $3) }
 | control { $1 }
-| THROW non_apply non_apply { Throw($2, $3) }
+| THROW non_apply { Throw($2) }
 
 control:
 | IF sep_expr_sep THEN sep_expr_sep ELSE sep_star expr { Conditional($2,$4,$7) }

src/sast.ml

@@ -23,7 +23,7 @@ type expr_detail =
   | Block of expr_typed list
   | Conditional of expr_typed * expr_typed * expr_typed
   | For of new_variable_name * expr_typed * expr_typed
-  | Throw of expr_typed * expr_typed
+  | Throw of expr_typed
   | Init of new_variable_name * expr_typed
   | Assign of variable_name * expr_typed
   | Struct of type_name * ((string * expr_typed) list)

src/typed_ast.ml

@@ -106,6 +106,17 @@ let check_unique_functions fundefs externs =
       else nfundef :: defs
   )
 
+let chord_of sexpr =
+  begin match sexpr with
+    (* use function in standard library on chordable (chord, pitch, int) exprs *)
+    | (_, Ast.Int) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"),
+        [ Sast.FunApply(Sast.NhFunction("PitchOfInt"), [(Sast.LitInt(0),Ast.Int)]),
+          Ast.Type("pitch") ])
+    | (_, Ast.Type("pitch")) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"), [sexpr])
+    | (expr, Ast.Type("chord")) -> expr
+    | _ -> failwith "This expression is not chordable"
+  end, Ast.Type("chord")
+
 let rec sast_expr env tfuns_ref = function
   | Ast.LitBool(x) -> Sast.LitBool(x), Ast.Bool
   | Ast.LitInt(x) -> Sast.LitInt(x), Ast.Int
@@ -133,43 +144,32 @@ let rec sast_expr env tfuns_ref = function
       | Ast.And | Ast.Or -> failwith "This operation is only defined for bool"
 
       | Ast.Concat -> begin match lt, rt with
-        (* disallow chords to be concatted *)
-        | Ast.Array(l), Ast.Array(r)
-          when l = r && l <> Ast.Type("pitch") ->
-          Sast.Binop(lexprt,op,rexprt), lt
-        (* note that track is a type, not array *)
-        | Ast.Type("track"), Ast.Type("track")
-          -> Sast.Binop(lexprt,op,rexprt), lt
-        | _ -> failwith "This operation is only defined for same nonprimitive types" end
-      | Ast.Chord -> begin match lt, rt with
-        (* chordOp can be with pitch or chord or int *)
-        | Ast.Array(Ast.Type("pitch")), Ast.Array(Ast.Type("pitch"))
-        | Ast.Type("pitch"), Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Type("pitch")), Ast.Type("pitch")
-        | Ast.Type("pitch"), Ast.Type("pitch")
-        | Ast.Int, Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Type("pitch")), Ast.Int
-        | Ast.Int, Ast.Type("pitch")
-        | Ast.Type("pitch"), Ast.Int
-        | Ast.Int, Ast.Int
-          -> Sast.Binop(lexprt,op,rexprt), Ast.Array(Ast.Type("pitch"))
-        | _ -> failwith "This operation is only defined for pitch, chord, or int" end
-      | Ast.Octave -> begin match lt, rt with
-        | Ast.Type("pitch"), Ast.Int
-        | Ast.Int, Ast.Int -> Sast.Binop(lexprt,op,rexprt), Ast.Type("pitch")
-        | _ -> failwith "This operation is only defined for [pitch int] and int" end
-      | Ast.Zip -> begin match lt, rt with
-        (* zip works with music arr, chord, pitch, or int/float *)
-        | Ast.Float, Ast.Int
-        | Ast.Float, Ast.Type("pitch")
-        | Ast.Float, Ast.Array(Ast.Type("pitch"))
-        | Ast.Float, Ast.Array(Ast.Array(Ast.Type("pitch")))
-        | Ast.Array(Ast.Float), Ast.Int
-        | Ast.Array(Ast.Float), Ast.Type("pitch")
-        | Ast.Array(Ast.Float), Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Float), Ast.Array(Ast.Array(Ast.Type("pitch")))
-          -> Sast.Binop(lexprt,op,rexprt), Ast.Type("track")
-        | _ -> failwith "Incorrect types for zip" end
+        (* also allow tracks to be concatted *)
+        | Ast.Type("track"), Ast.Type("track") -> Sast.FunApply(NhFunction("ConcatTracks"),[lexprt;rexprt]), lt
+        | Ast.Array(l), Ast.Array(r) when l = r -> Sast.Binop(lexprt,op,rexprt), lt
+        | _ -> failwith "Concat is only for defined for same typed arrays and tracks" end
+
+      | Ast.Chord ->
+          (* guarantee that chord binop is between two chords *)
+          Sast.FunApply(NhFunction("ChordOfChords"),[chord_of lexprt; chord_of rexprt]), Ast.Type("chord")
+
+      | Ast.Octave ->
+          let lexprt = match lt with
+            | Ast.Type("pitch") -> lexprt
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [lexprt]), Ast.Type("pitch")
+            | _ -> failwith "octave only defined for pitch or int on left side"
+          in if rt = Ast.Int
+            then Sast.FunApply(NhFunction("AddPitchOctave"), [lexprt;rexprt]), Ast.Type("pitch")
+            else failwith "octave only defined for int on right side"
+
+      | Ast.Zip ->
+          if (lt = Ast.Float || lt = Ast.Array(Ast.Float))
+            then let rexprt = match rt with
+                (* either chord or array of chord is valid for zip *)
+                | Ast.Array(Ast.Type("chord")) -> rexprt
+                | _ -> chord_of rexprt
+              in Sast.Binop(lexprt,op,rexprt), Ast.Type("track")
+            else failwith "left side expression of zip must of float or array of float"
     end
   | Ast.Uniop(op, expr) ->
     let exprt = sast_expr env tfuns_ref expr in
@@ -183,7 +183,19 @@ let rec sast_expr env tfuns_ref = function
 
       | Ast.Sharp | Ast.Flat when t = Ast.Int || t = Ast.Type("pitch")
         -> Sast.Uniop(op, exprt), Ast.Type("pitch")
-      |Ast.Sharp | Ast.Flat -> failwith "This operator is only defined for int or pitch"
+
+      | Ast.Sharp -> let tpitch = Ast.Type("pitch") in
+          let exprt = match t with
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch
+            | Ast.Type("pitch") -> exprt
+            | _ -> failwith "sharp is only defined for int or pitch"
+          in Sast.FunApply(NhFunction("SharpPitch"), [exprt]), tpitch
+      | Ast.Flat -> let tpitch = Ast.Type("pitch") in
+          let exprt = match t with
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch
+            | Ast.Type("pitch") -> exprt
+            | _ -> failwith "flat is only defined for int or pitch"
+          in Sast.FunApply(NhFunction("FlatPitch"), [exprt]), tpitch
     end
 
   | Ast.FunApply(name, arg_exprs) ->
@@ -280,8 +292,8 @@ let rec sast_expr env tfuns_ref = function
   | For(loop_var_name, items, body) ->
     ignore (loop_var_name, items, body); failwith "Type checking not implemented for For"
 
-  | Throw(retval, msg) ->
-    ignore (retval, msg); failwith "Type checking not implemented for Throw"
+  | Throw(msg) ->
+    ignore msg; failwith "Type checking not implemented for Throw"
 
   | Assign(names, expr) ->
       let (value, tvalue) = sast_expr env tfuns_ref expr in