Skip to content

Instantly share code, notes, and snippets.

@yyamasak
Last active May 15, 2018 09:08
Show Gist options
  • Save yyamasak/1b8fa0ea5090053fbb576c2d20b35b0c to your computer and use it in GitHub Desktop.
Save yyamasak/1b8fa0ea5090053fbb576c2d20b35b0c to your computer and use it in GitHub Desktop.
A challenge to make Tcl expr handle Inf or NaN transparently (but failed because of [expr {NaN}])
proc is_computable_double {val} {
expr {[string is double -strict $val] && ![is_nan $val]}
}
proc is_nan {val} {
string match -nocase [string trimleft $val +-] "nan"
}
proc is_infinite {val} {
expr {$val == Inf || $val == -Inf}
}
proc sqrtf {a} {
if {[is_computable_double $a] && $a >= 0} {
expr {sqrt($a)}
} else {
return NaN
}
}
proc divf {a b} {
if {$a == 0 && $b == 0 || [is_infinite $a] && [is_infinite $b]} {
return NaN
} elseif {[is_nan $a] || [is_nan $b]} {
return NaN
} elseif {![string is double -strict $a] || ![string is double -strict $a]} {
return NaN
} else {
expr {$a / double($b)}
}
}
proc mulf {a b} {
if {[is_infinite $a] && $b == 0} {
return NaN
} elseif {$a == 0 && [is_infinite $b]} {
return NaN
} elseif {[is_nan $a] || [is_nan $b]} {
return NaN
} elseif {![string is double -strict $a] || ![string is double -strict $a]} {
return NaN
} else {
expr {$a * double($b)}
}
}
proc subf {a b} {
if {$a == Inf && $b == Inf} {
return NaN
} elseif {$a == -Inf && $b == -Inf} {
return NaN
} elseif {[is_nan $a] || [is_nan $b]} {
return NaN
} elseif {![string is double -strict $a] || ![string is double -strict $a]} {
return NaN
} else {
expr {$a - double($b)}
}
}
proc addf {a b} {
if {$a == Inf && $b == -Inf} {
return NaN
} elseif {$a == -Inf && $b == Inf} {
return NaN
} elseif {[is_nan $a] || [is_nan $b]} {
return NaN
} elseif {![string is double -strict $a] || ![string is double -strict $a]} {
return NaN
} else {
expr {$a + double($b)}
}
}
proc lopf {op vals} {
set res {}
foreach v $vals {
if {$res eq {}} {
set res $v
} else {
set res [$op $res $v]
}
}
return $res
}
proc tcl::mathfunc::sqrtf {a} {
::sqrtf $a
}
proc tcl::mathfunc::divf {args} {
::lopf ::divf $args
}
proc tcl::mathfunc::mulf {args} {
::lopf ::mulf $args
}
proc tcl::mathfunc::subf {a b} {
::lopf ::subf $args
}
proc tcl::mathfunc::addf {args} {
::lopf ::addf $args
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment