Skip to content

Instantly share code, notes, and snippets.

@soapdog

soapdog/btc.red

Created December 17, 2017 01:15
Show Gist options
  • Save soapdog/ab67db55ec6e7386eb68542d5d3df64b to your computer and use it in GitHub Desktop.
Save soapdog/ab67db55ec6e7386eb68542d5d3df64b to your computer and use it in GitHub Desktop.
Download ZIP
Calculo de rendimento em BTC na Walltime
Raw
btc.red
Red [
Title: "LuiBTC"
Author: "Andre Garzia"
Needs: 'view
]
do %json.red
view [
title "LuiBTC"
style txt: text
group-box "Entrada" 1 [
text "Dinheiro investido" investimento: field
text "Cotação do dia do investimento" cotacao_dia: field
button "Calcular" [
meta_raw: read https://s3.amazonaws.com/data-production-walltime-info/production/dynamic/meta.json
meta: load-json meta_raw
best_offer: select meta "best_offer"
brl_xbt_raw: select best_offer "brl-xbt"
brl_xbt: split brl_xbt_raw "/"
cotacao_atual/text: form either (length? brl_xbt) > 1
[ (load first brl_xbt) / (load last brl_xbt) ]
[ first brl_xbt ]
i: load investimento/text
cd: load cotacao_dia/text
ca: load cotacao_atual/text
total_btc/text: form i / cd
rendimento/text: form round/to ((ca - cd) * 100 / cd) 0.01
lucro/text: form round/to (i * ((load rendimento/text) / 100)) 0.01
total_real/text: form round/to (i + (load lucro/text)) 0.01
]
img: image loose %logo.png
]
group-box "Resultado" 1 [
text "Cotação atual" cotacao_atual: field
text "Total em BTC" total_btc: field
text "Rendimento em %" rendimento: field
text "Lucro em Real" lucro: field
text "Total em Real" total_real: field
]
];;
Raw
json.red
Red [
File: %json.red
Title: "Red-JSON codec"
Purpose: "Convert JSON to Red, and vice versa."
Author: "Gregg Irwin"
;Date: 09-Sep-2016
Version: 0.0.1
History: {
0.0.1 09-Sep-2016 "First release." Gregg
}
license: [
http://www.apache.org/licenses/LICENSE-2.0
and "The Software shall be used for Good, not Evil."
]
References: [
http://www.json.org/
https://www.ietf.org/rfc/rfc4627.txt
http://www.rfc-editor.org/rfc/rfc7159.txt
http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
]
Notes: {
- Ported from %json.r, by Romano Paolo Tenca, Douglas Crockford, and Gregg Irwin.
- Further research: JSON libs by Chris Ross-Gill, Kaj de Vos, and @WiseGenius.
? Do we want to have a single context or separate encode/decode contexts?
? Do we want to use a stack with parse, or recursive load-json/decode calls?
- Unicode support is in the works.
- Pretty formatting from %json.r removed. Determine what formatting options we want.
- Would like to add more detailed decode error info.
- JSON document is empty.
- Invalid value.
- Missing name for object member.
- Missing colon after name of object member.
- Missing comma or right curly brace after object member.
- Missing comma or ] after array element.
- Invalid \uXXXX escape.
- Invalid surrogate pair.
- Invalid backslash escape.
- Missing closing quotation mark in string.
- Numeric overflow.
- Missing fraction in number.
- Missing exponent in number.
}
]
json-ctx: object [
;-----------------------------------------------------------
;-- Generic support funcs
BOM: [
UTF-8 #{EFBBBF}
UTF-16-BE #{FEFF}
UTF-16-LE #{FFFE}
UTF-32-BE #{0000FEFF}
UTF-32-LE #{FFFE0000}
]
BOM-UTF-16?: func [data [string! binary!]][
any [find/match data BOM/UTF-16-BE find/match data BOM/UTF-16-LE]
]
BOM-UTF-32?: func [data [string! binary!]][
any [find/match data BOM/UTF-32-BE find/match data BOM/UTF-32-LE]
]
; MOLD adds quotes string!, but not all any-string! values.
enquote: func [str [string!] "(modified)"][append insert str {"} {"}]
high-surrogate?: func [codepoint [integer!]][
all [codepoint >= D800h codepoint <= DBFFh]
]
low-surrogate?: func [codepoint [integer!]][
all [codepoint >= DC00h codepoint <= DFFFh]
]
; map-each: function [
; "Evaluates body for each value in a series, returning all results."
; 'word [word! block!] "Word, or words, to set on each iteration"
; data [series!] ; map!
; body [block!]
; ][
; collect [foreach :word data [keep/only do body]]
; ]
translit: func [
"Tansliterate sub-strings in a string"
string [string!] "Input (modified)"
rule [block! bitset!] "What to change"
xlat [block! function!] "Translation table or function. MUST map a string! to a string!."
/local val
][
parse string [
some [
change copy val rule (val either block? :xlat [xlat/:val][xlat val])
| skip
]
]
string
]
;-----------------------------------------------------------
;-- JSON backslash escaping
;TBD: I think this can be improved. --Gregg
json-to-red-escape-table: [
; JSON Red
{\"} "^""
{\\} "\"
{\/} "/"
{\b} "^H" ; #"^(back)"
{\f} "^L" ; #"^(page)"
{\n} "^/"
{\r} "^M"
{\t} "^-"
]
red-to-json-escape-table: reverse copy json-to-red-escape-table
json-esc-ch: charset {"t\/nrbf} ; Backslash escaped JSON chars
json-escaped: [#"\" json-esc-ch] ; Backslash escape rule
red-esc-ch: charset {^"^-\/^/^M^H^L} ; Red chars requiring JSON backslash escapes
decode-backslash-escapes: func [string [string!] "(modified)"][
translit string json-escaped json-to-red-escape-table
]
encode-backslash-escapes: func [string [string!] "(modified)"][
translit string red-esc-ch red-to-json-escape-table
]
;ss: copy string: {abc\"\\\/\b\f\n\r\txyz}
;decode-backslash-escapes string
;encode-backslash-escapes string
;ss = string
;-----------------------------------------------------------
;-- JSON decoder
;-----------------------------------------------------------
;# Basic rules
ws: charset " ^-^/^M" ; Whitespace
ws*: [any ws]
ws+: [some ws]
sep: [ws* #"," ws*] ; JSON value separator
digit: charset "0123456789"
non-zero-digit: charset "123456789"
hex-char: charset "0123456789ABCDEFabcdef"
ctrl-char: charset [#"^@" - #"^_"] ; Control chars 0-31
chars: charset [not {\"} #"^@" - #"^_"] ; Unescaped chars (NOT creates a virtual bitset)
; TBD: Unicode
;not-low-ascii-char: charset [not #"^(00)" - #"^(127)"]
;not-ascii-char: charset [not #"^(00)" - #"^(255)"]
; everything but \ and "
; Defining it literally this way, rather than a [NOT charset] rule, takes ~70K
; Need to see if it's faster one way or the other.
; unescaped-char: charset [
; #"^(20)" - #"^(21)" ; " !"
; #"^(23)" - #"^(5B)" ; #$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[
; #"^(5D)" - #"^(10FFF)" ; ]^^_`abcdefghijklmnopqrstuvwxyz{|}~ ...U+
; ]
;-----------------------------------------------------------
;-- JSON value rules
;-----------------------------------------------------------
;-----------------------------------------------------------
;-- Number
sign: [#"-"]
; Integers can't have leading zeros, but zero by itself is valid.
int: [[non-zero-digit any digit] | digit]
frac: [#"." some digit]
exp: [[#"e" | #"E"] opt [#"+" | #"-"] some digit]
number: [opt sign int opt frac opt exp]
numeric-literal: :number
;-----------------------------------------------------------
;-- String
string-literal: [
#"^"" copy _str [
any [some chars | #"\" [#"u" 4 hex-char | json-esc-ch]]
] #"^"" (
if not empty? _str: any [_str copy ""] [
;!! If we reverse the decode-backslash-escapes and replace-unicode-escapes
;!! calls, the string gets munged (extra U+ chars). Need to investigate.
decode-backslash-escapes _str ; _str is modified
replace-unicode-escapes _str ; _str is modified
;replace-unicode-escapes decode-backslash-escapes _str
]
)
]
decode-unicode-char: func [
"Convert \uxxxx format (NOT simple JSON backslash escapes) to a Unicode char"
ch [string!] "4 hex digits"
][
buf: {#"^^(0000)"} ; Don't COPY buffer, reuse it
if not parse ch [4 hex-char] [return none] ; Validate input data
attempt [load head change at buf 5 ch] ; Replace 0000 section in buf
]
replace-unicode-escapes: func [
s [string!] "(modified)"
/local c
][
parse s [
any [
some chars ; Pass over unescaped chars
| json-escaped ; Pass over simple backslash escapes
| change ["\u" copy c 4 hex-char] (decode-unicode-char c)
;| "\u" followed by anything else is an invalid \uXXXX escape
]
]
s
]
;str: {\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%&*()_+-=[]{}|;:',./<>?}
;mod-str: decode-backslash-escapes json-ctx/replace-unicode-escapes copy str
;mod-str: json-ctx/replace-unicode-escapes decode-backslash-escapes copy str
;-----------------------------------------------------------
;-- Object
json-object: [
; Emit a new block to our output target, and push it on our
; working stack, to handle nested structures. Emit returns
; the insertion point for another value to go out into '_res,
; but we want the target to be the block we just added, so
; we reset '_res to that after 'emit is done.
#"{" (push emit copy [] _res: last _res)
ws* opt property-list
; This is a little confusing. We're at the tail of our current
; output target, which is on our stack. We pop that, then need
; to back up one, which puts us AT the block of values we
; collected for this object in our output target. i.e., the
; values are in a sub-block at the first position now. We use
; that (FIRST) to make a map! and replace the block of values
; with the map! we just made. Note that a map is treated as a
; single value, like an object. Using a block as the new value
; requires using `change/only`.
#"}" (
_res: back pop
_res: change _res make map! first _res
)
]
property-list: [property any [sep property]]
property: [json-name (emit _str) json-value]
json-name: [ws* string-literal ws* #":"]
;-----------------------------------------------------------
;-- List
array-list: [json-value any [sep json-value]]
json-array: [
; Emit a new block to our output target, and push it on our
; working stack, to handle nested structures. Emit returns
; the insertion point for another value to go out into '_res,
; but we want the target to be the block we just added, so
; we reset '_res to that after 'emit is done.
#"[" (push emit copy [] _res: last _res)
ws* opt array-list
#"]" (_res: pop)
]
;-----------------------------------------------------------
;-- Any JSON Value (top level JSON parse rule)
json-value: [
ws*
[
"true" (emit true) ; Literals must be lowercase
| "false" (emit false)
| "null" (emit none)
| json-object
| json-array
| string-literal (emit _str)
| copy _str numeric-literal (emit load _str) ; Number
mark: ; Set mark for failure location
]
ws*
]
;-----------------------------------------------------------
;-- Decoder data structures
; The stack is used to handle nested structures (objects and lists)
stack: copy []
push: func [val][append/only stack val]
pop: does [take/last stack]
_out: none ; Our overall output target/result
_res: none ; The current output position where new values are inserted
_str: none ; Where string value parse results go
mark: none ; Current parse position
; Add a new value to our output target, and set the position for
; the next emit to the tail of the insertion.
;!! I really don't like how this updates _res as a side effect. --Gregg
emit: func [value][_res: insert/only _res value]
;-----------------------------------------------------------
;-- Main decoder func
set 'load-json func [
[catch]
"Convert a json string to Red data"
input [string!] "The json string"
][
_out: _res: copy [] ; These point to the same position to start with
mark: input
either parse input json-value [pick _out 1][
throw make error! form reduce [
"Invalid json string. Near:"
either tail? mark ["<end of input>"] [mold copy/part mark 40]
]
]
]
;-------------------------------------------------------------------------------
;-------------------------------------------------------------------------------
;-------------------------------------------------------------------------------
;-----------------------------------------------------------
;-- JSON encoder
;-----------------------------------------------------------
; Indentation support, so we can make the JSON output look decent.
dent: copy ""
dent-size: 4
indent: does [append/dup dent #" " dent-size]
outdent: does [remove/part dent dent-size]
encode-char: func [
"Convert a single char to \uxxxx format (NOT simple JSON backslash escapes)."
char [char! string!]
][
if string? char [char: first char]
;rejoin ["\u" to-hex/size to integer! char 4]
append copy "\u" to-hex/size to integer! char 4
]
;-------------------------------------------------------------------------------
;!! This is an optimization. The main reason it's here is that Red doesn't
;!! have a GC yet. Generating the lookup table once, and using that, prevents
;!! repeated block allocations every time we encode a control character.
make-ctrl-char-esc-table: function [][
collect [
;!! FORM is used here, when building the table, because TRANSLIT
; requires values to be strings. Yes, that's leaking it's
; abstraction a bit, which has to do with it using COPY vs SET
; in its internal PARSE rule.
keep reduce [form ch: make char! 0 encode-char ch]
repeat i 31 [keep reduce [form ch: make char! i encode-char ch]]
]
]
ctrl-char-esc-table: make-ctrl-char-esc-table
;-------------------------------------------------------------------------------
encode-control-chars: func [
"Convert all control chars in string to \uxxxx format"
string [any-string!] "(modified)"
][
if find string ctrl-char [
;translit string ctrl-char :encode-char ; Use function to encode
translit string ctrl-char ctrl-char-esc-table ; Optimized table lookup approach
]
string
]
;encode-control-chars "^@^A^B^C^D^E^F^G^H^-^/^K^L^M^N^O^P^Q^R^S^T^U^V^W^X^Y^Z^[^\^]^(1E)^_ "
; The reason this func does not copy the string is that a lot of
; values will have been FORMed or MOLDed when they are passed to
; it, so there's no sense in copying them again. The only time it's
; a problem is for string values themselves.
;TBD: Encode unicode chars?
encode-red-string: func [string "(modified) Caller should copy"][
encode-control-chars encode-backslash-escapes string
;TBD translit string not-ascii-char :encode-char
]
red-to-json-name: func [val][
append enquote encode-red-string form val ":"
]
; Types that map directly to a known JSON type.
json-type!: union any-block! union any-string! make typeset! [
none! logic! integer! float! percent! map! object! ; decimal!
]
red-to-json-value: func [val][
;?? Is it worth the extra lines to make each type a separate case?
; The switch cases will look nicer if we do; more table like.
switch/default type?/word :val [
string! [enquote encode-red-string copy val] ; COPY to prevent mutation
none! ["null"] ; JSON value MUST be lowercase
logic! [pick ["true" "false"] val] ; JSON value MUST be lowercase
integer! float! [form val] ; TBD: add decimal!
percent! [form make float! val] ; FORM percent! includes sigil
map! object! [map-to-json-object val] ; ?? hash!
word! [
either all [
not error? try [get val] ; Error means word ref's no value. FORM and escape it.
find json-type! type? get val ; Not a type json understands. FORM and escape it.
][
red-to-json-value get val
][
; No-value error, or non-JSON types become quoted strings.
enquote encode-red-string form val
]
]
][
either any-block? :val [block-to-json-list val] [
; FORM forces binary! values to strings, so newlines escape properly.
enquote encode-red-string either any-string? :val [form val] [mold :val]
]
]
]
;TBD: Eventually we should have a nice dlm string tool in Red. Is it worth
; including our own for the list/object cases?
block-to-json-list: func [block [any-block!] /local result sep][
indent
result: copy "[^/"
foreach value block [
append result rejoin [dent red-to-json-value :value ",^/"]
]
outdent
append clear any [find/last result "," tail result] rejoin ["^/" dent "]"]
;single-line-reformat result
result
]
map-to-json-object: func [map [map!] /local result sep][
indent
result: copy "{^/"
foreach word words-of map [
append result rejoin [
dent red-to-json-name :word " "
red-to-json-value map/:word ",^/"
]
]
outdent
append clear any [find/last result "," tail result] rejoin ["^/" dent "}"]
;single-line-reformat result
result
]
;-----------------------------------------------------------
;-- Main encoder func
set 'to-json function [
[catch]
"Convert red data to a json string"
data
][
result: make string! 4000 ;!! factor this up from molded data length?
foreach value compose/only [(data)] [
append result red-to-json-value value
]
result
]
; Even if we don't do full pretty formatting of JSON, it might still be nice
; to do the single-line bit.
; single-line-cleanup: function [string][
; table: ["{ " "{" "[ " "[" " }" "}" " ]" "]"] ; From/To Old/New Dirty/Clean values
; dirty: ["{ " | "[ " | " }" | " ]"]
; translit string dirty table
; ]
; ;print mold single-line-cleanup "{ a [ b { c } d ] f }"
;
; single-line-reformat: function [
; "Reformats a block/object to a single line if it's short enough."
; val
; ][
; either 80 >= length? join dent s: trim/lines copy val [
; single-line-cleanup s
; ][val]
; ]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment