├── .gitignore ├── LICENSE ├── README.md ├── all-test.red ├── control-monad-test.red ├── control-monad.red ├── data-char-test.red ├── data-char.red ├── data-either-test.red ├── data-either.red ├── data-function-test.red ├── data-function.red ├── data-list-test.red ├── data-list.red ├── data-maybe-test.red ├── data-maybe.red ├── haskell.red ├── playground.red ├── playground.sh ├── prelude-test.red ├── prelude.red ├── quick-test ├── quick-test.r ├── quick-test.red ├── quick-test.reds ├── quick-unit-test.r ├── run-test.r └── tests │ ├── overwrite-test.reds │ ├── qt-test.r │ └── qt-test.reds └── run-test /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .\#* 3 | /play.sh 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 unchartedworks 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HaskellRed 2 | 3 | A functional library for Red programmers. 4 | 5 | # Prerequisites 6 | - Red 0.6.3+ 7 | 8 | # How to use it 9 | To use HaskellRed, just include haskell.red in your file. 10 | For instance, 11 | 12 | ``` 13 | #include %haskell.red 14 | 15 | print isControl #"t" 16 | print map :to-string [1 2 3] 17 | ``` 18 | 19 | # Examples 20 | ## Data List 21 | ### map 22 | ``` 23 | xs: [1 2 3] 24 | map :to-string xs 25 | ``` 26 | 27 | ``` 28 | ["1" "2" "3"] 29 | ``` 30 | 31 | ### filter 32 | ``` 33 | xs: [1 "2" 3 "4" 5 "6"] 34 | filter :integer? xs 35 | ``` 36 | 37 | ``` 38 | [1 3 5] 39 | ``` 40 | 41 | ### foldl 42 | ``` 43 | xs: [1 2 3 4] 44 | f: func [y x][x * y] 45 | foldl :f 1 xs 46 | ``` 47 | 48 | ``` 49 | 24 50 | ``` 51 | 52 | ## Data Function 53 | ### Function Composition 54 | ``` 55 | f1: func [x][x * 2] 56 | f2: func [x][length? x] 57 | f: :f1 . :f2 58 | f "abc" 59 | ``` 60 | ``` 61 | 6 62 | ``` 63 | 64 | ## Maybe 65 | ``` 66 | hit: [x] -> [Just (x + 8)] 67 | stand: [x] -> [either x > 21 [Nothing][Just x]] 68 | win: [x] -> [Just "$1000"] 69 | showtime: [x] -> [Just ("You win " ++ x ++ "!")] 70 | 71 | blackjack: [x [object!]] -> [x >>= :hit >>= :hit >>= :stand >>= :win >>= :showtime] 72 | blackjack Just 3 73 | ``` 74 | 75 | ``` 76 | Just "You win $1000!" 77 | ``` 78 | 79 | ## Control Monad 80 | ``` 81 | Red [ 82 | Title: "all test script" 83 | Author: "unchartedworks" 84 | File: %all-test.red 85 | Tabs: 4 86 | Rights: "unchartedworks. All rights reserved." 87 | License: "MIT" 88 | ] 89 | 90 | #include %haskell.red 91 | 92 | isTestFile: [x] -> [(isSuffixOf "-test.red" (to-string x)) && (%all-test.red <> x) && (not (isPrefixOf ".#" (to-string x)))] 93 | filterTestFiles: [xs] -> [filter :isTestFile xs] 94 | includeFile: [x] -> [#include x] 95 | includeFiles: [xs] -> [map :includeFile xs] 96 | 97 | %./ >>>= [read filterTestFiles includeFiles] 98 | ``` 99 | 100 | For more documentation, please refer to Haskell documentation and the test cases of HaskellRed. 101 | 102 | # Development 103 | ## Test 104 | ```./run-test``` 105 | 106 | screen shot 2017-10-30 at 14 24 10 107 | -------------------------------------------------------------------------------- /all-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "all test script" 3 | Author: "unchartedworks" 4 | File: %all-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %haskell.red 11 | 12 | isTestFile: [x] -> [(isSuffixOf "-test.red" (to-string x)) && (%all-test.red <> x) && (not (isPrefixOf ".#" (to-string x)))] 13 | filterTestFiles: [xs] -> [filter :isTestFile xs] 14 | includeFile: [x] -> [#include x] 15 | includeFiles: [xs] -> [map :includeFile xs] 16 | 17 | %./ >>>= [read filterTestFiles includeFiles] 18 | -------------------------------------------------------------------------------- /control-monad-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Control.Monad test script" 3 | Author: "unchartedworks" 4 | File: %control-monad-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %data-function.red 13 | #include %data-list.red 14 | #include %prelude.red 15 | #include %data-maybe.red 16 | #include %data-either.red 17 | #include %control-monad.red 18 | 19 | ~~~start-file~~~ "control-monad" 20 | 21 | ===start-group=== ">>=" 22 | hit: [x] -> [Just (x + 8)] 23 | stand: [x] -> [either x > 21 [Nothing][Just x]] 24 | win: [x] -> [Just "$1000"] 25 | showtime: [x] -> [Just ("You win " ++ x ++ "!")] 26 | 27 | blackjack: [x [object!]] -> [x >>= :hit >>= :hit >>= :stand >>= :win >>= :showtime] 28 | 29 | ===start-group=== ">>=" 30 | ;;List 31 | --test-- "[integer!] -> [integer!] 1" 32 | y: [4] 33 | z: [3] >>= ([x] -> [reduce [x + 1]]) 34 | --assert* [y == z] 35 | 36 | --test-- "[integer!] -> [integer!] 2" 37 | y: [] 38 | z: [] >>= ([x] -> [reduce [x + 1]]) 39 | --assert* [y == z] 40 | 41 | --test-- "[integer!] -> [integer!] 3" 42 | y: [3 4 5] 43 | z: [1 2 3] >>= ([x] -> [reduce [x + 1]]) >>= ([x] -> [reduce [x + 1]]) 44 | --assert* [y == z] 45 | 46 | --test-- "[integer!] -> [integer!] 4" 47 | y: [] 48 | z: [1 2 3] >>= ([x] -> [reduce [x + 1]]) >>= ([x] -> [[]]) 49 | --assert* [y == z] 50 | 51 | ;;Maybe 52 | --test-- "Just integer! -> Just string!" 53 | y: Just "You win $1000!" 54 | z: blackjack Just 3 55 | --assert* [y == z] 56 | 57 | --test-- "Just integer! -> Nothing" 58 | y: Nothing 59 | z: blackjack Just 8 60 | --assert* [y == z] 61 | 62 | ;;Either 63 | --test-- "Right integer! -> Left string! 1" 64 | f: [x] -> [either (x == 0) [Left "division by zero"][Right (x + 1)]] 65 | y: Left "division by zero" 66 | z: (Right 0) >>= :f 67 | --assert* [y == z] 68 | 69 | --test-- "Right integer! -> Left string! 2" 70 | f: [x] -> [either (x == 0) [Left "error 1"][Right (x + 1)]] 71 | g: [x] -> [either (x > 8) [Left "error 2"][Right (x * 2)]] 72 | y: Left "error 2" 73 | z: (Right 8) >>= :f >>= :g 74 | --assert* [y == z] 75 | 76 | --test-- "Right integer! -> Right integer! 1" 77 | f: [x] -> [either (x == 0) [Left "division by zero"][Right (x + 1)]] 78 | y: Right 4 79 | z: (Right 3) >>= :f 80 | --assert* [y == z] 81 | 82 | --test-- "Right integer! -> Right integer! 2" 83 | f: [x] -> [either (x == 0) [Left "error 1"][Right (x + 1)]] 84 | g: [x] -> [either (x > 8) [Left "error 2"][Right (x * 2)]] 85 | y: Right 8 86 | z: (Right 3) >>= :f >>= :g 87 | --assert* [y == z] 88 | 89 | --test-- "Left string! -> Left string!" 90 | f: [x] -> [either (x == 0) [Left "division by zero"][Right (x + 1)]] 91 | y: Left "division by zero" 92 | z: y >>= :f 93 | --assert* [y == z] 94 | ===end-group=== 95 | 96 | ===start-group=== ">>" 97 | ;;List 98 | --test-- "[integer!] -> [integer!] 1" 99 | y: [4] 100 | z: [3] >> [4] 101 | --assert* [y == z] 102 | 103 | --test-- "[integer!] -> [integer!] 2" 104 | y: [] 105 | z: [] >> [4] 106 | --assert* [y == z] 107 | 108 | --test-- "[integer!] -> [integer!] 3" 109 | y: [3 4 5] 110 | z: [1 2 3] >> [3 4 5] 111 | --assert* [y == z] 112 | 113 | --test-- "[integer!] -> [integer!] 4" 114 | y: [] 115 | z: [1 2 3] >> [] 116 | --assert* [y == z] 117 | 118 | ;;Maybe 119 | --test-- "Just integer! -> Nothing 1" 120 | y: Nothing 121 | z: (Just 0) >> Nothing 122 | --assert* [y == z] 123 | 124 | --test-- "Just integer! -> Nothing 2" 125 | y: Nothing 126 | z: (Just 8) >> Nothing >> (Just 6) 127 | --assert* [y == z] 128 | 129 | --test-- "Just integer! -> Just integer! 1" 130 | y: Just 4 131 | z: (Just 8) >> (Just 6) >> (Just 4) 132 | --assert* [y == z] 133 | 134 | --test-- "Just integer! -> Just integer! 2" 135 | y: Just 2 136 | z: (Just 8) >> (Just 6) >> (Just 4) >> (Just 2) 137 | --assert* [y == z] 138 | 139 | --test-- "Just integer! -> Just integer! 3" 140 | y: Nothing 141 | z: (Just 8) >> Nothing >> (Just 4) >> (Just 2) 142 | --assert* [y == z] 143 | 144 | ;;Either 145 | --test-- "Right integer! -> Left string! 1" 146 | y: Left "division by zero" 147 | z: (Right 0) >> Left "division by zero" 148 | --assert* [y == z] 149 | 150 | --test-- "Right integer! -> Left string! 2" 151 | y: Left "error 2" 152 | z: (Right 8) >> (Left "error 2") >> (Right 6) 153 | --assert* [y == z] 154 | 155 | --test-- "Right integer! -> Right integer! 1" 156 | y: Right 4 157 | z: (Right 8) >> (Right 6) >> Right 4 158 | --assert* [y == z] 159 | 160 | --test-- "Right integer! -> Right integer! 2" 161 | y: Right 2 162 | z: (Right 8) >> (Right 6) >> (Right 4) >> (Right 2) 163 | --assert* [y == z] 164 | 165 | --test-- "Left string! -> Left string!" 166 | y: Left "division by zero" 167 | z: y >> Left "hello" 168 | --assert* [y == z] 169 | ===end-group=== 170 | 171 | ===start-group=== "liftM" 172 | ;;List 173 | --test-- "[integer!] -> [integer!] 1" 174 | f: [x] -> [x + 1] 175 | y: [5] 176 | z: liftM :f [4] 177 | --assert* [y == z] 178 | 179 | --test-- "[integer!] -> [integer!] 2" 180 | f: [x] -> [x + 1] 181 | y: [] 182 | z: liftM :f [] 183 | --assert* [y == z] 184 | 185 | --test-- "[integer!] -> [integer!] 3" 186 | f: [x] -> [x + 1] 187 | y: [2 3 4] 188 | z: liftM :f [1 2 3] 189 | --assert* [y == z] 190 | 191 | ;;Maybe 192 | --test-- "Just integer! -> Nothing 1" 193 | f: [x] -> [x + 1] 194 | y: Nothing 195 | z: liftM :f Nothing 196 | --assert* [y == z] 197 | 198 | --test-- "Just integer! -> Nothing 2" 199 | f: [x] -> [x + 1] 200 | y: Just 9 201 | z: liftM :f (Just 8) 202 | --assert* [y == z] 203 | 204 | ;;Either 205 | --test-- "Right integer! -> Left string! 1" 206 | f: [x] -> [x + 1] 207 | y: Left "division by zero" 208 | z: liftM :f Left "division by zero" 209 | --assert* [y == z] 210 | 211 | --test-- "Right integer! -> Right integer! 1" 212 | f: [x] -> [x + 1] 213 | y: Right 9 214 | z: liftM :f (Right 8) 215 | --assert* [y == z] 216 | ===end-group=== 217 | 218 | ===start-group=== "liftM2" 219 | ;List 220 | ; --test-- "[integer!] -> [integer!] 1" 221 | ; f: [x y] -> [x + y] 222 | ; y: [5] 223 | ; z: liftM2 :f [1 2] [5] 224 | ; --assert* [y == z] 225 | 226 | ; --test-- "[integer!] -> [integer!] 2" 227 | ; f: [x] -> [x + 1] 228 | ; y: [] 229 | ; z: liftM :f [] 230 | ; --assert* [y == z] 231 | 232 | ; --test-- "[integer!] -> [integer!] 3" 233 | ; f: [x] -> [x + 1] 234 | ; y: [2 3 4] 235 | ; z: liftM :f [1 2 3] 236 | ; --assert* [y == z] 237 | ===end-group=== 238 | ~~~end-file~~~ 239 | -------------------------------------------------------------------------------- /control-monad.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Control.Monad" 3 | Author: "unchartedworks" 4 | File: %control-monad.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | sequencially-compose-pass*: function [ 11 | "Sequentially compose two actions, passing any value produced by the first as an argument to the second." 12 | x [object! series!] 13 | f [function!] 14 | ][ 15 | case [ 16 | object? x (sequencially-compose-pass-object* x :f) 17 | series? x (sequencially-compose-pass-series* x :f) 18 | ] 19 | ] 20 | 21 | sequencially-compose-pass-object*: function [ 22 | x [object!] 23 | f [any-function!] 24 | ][ 25 | case [ 26 | (isLeft x) x 27 | (isRight x) (f fromRight x) 28 | (isNothing x) Nothing 29 | (isJust x) (f fromJust x) 30 | ] 31 | ] 32 | 33 | sequencially-compose-pass-series*: function [ 34 | xs [series!] 35 | f [any-function!] 36 | ][ 37 | case [ 38 | (empty? xs) xs 39 | (series? xs) (concatMap :f xs) 40 | ] 41 | ] 42 | 43 | 44 | >>=: make op! :sequencially-compose-pass* 45 | 46 | sequencially-compose-discard*: function [ 47 | "Sequentially compose two actions, passing any value produced by the first as an argument to the second." 48 | x [object! series!] 49 | y [object! series!] 50 | ][ 51 | case [ 52 | ((object? x) && (object? y)) (sequencially-compose-discard-object* x y) 53 | ((series? x) && (series? y)) (sequencially-compose-discard-series* x y) 54 | ] 55 | ] 56 | 57 | sequencially-compose-discard-object*: function [ 58 | x [object!] 59 | y [object!] 60 | ][ 61 | case [ 62 | (isLeft x) x 63 | (isRight x) y 64 | (isNothing x) Nothing 65 | (isJust x) y 66 | ] 67 | ] 68 | 69 | sequencially-compose-discard-series*: function [ 70 | xs [series!] 71 | ys [series!] 72 | ][ 73 | case [ 74 | (empty? xs) xs 75 | (series? xs) ys 76 | ] 77 | ] 78 | 79 | >>: make op! :sequencially-compose-discard* 80 | 81 | ;;Basic Monad functions 82 | ; mapM: function [ 83 | ; "Map each element of a structure to a monadic action, evaluate these actions from left to right, and collect the results. For a version that ignores the results see mapM_." 84 | ; f: [any-function!] 85 | ; xs: [object! series!] 86 | ; ][ 87 | ; case [ 88 | ; object? x (mapM-object* :f xs) 89 | ; series? x (mapM-series* :f xs) 90 | ; ] 91 | ; ] 92 | 93 | ; mapM-object: function [ 94 | ; f: [any-function!] 95 | ; xs: [object! series!] 96 | ; ][ 97 | 98 | ; ] 99 | 100 | ; mapM-object: function [ 101 | ; f: [any-function!] 102 | ; xs: [object! series!] 103 | ; ][ 104 | ; foldl :f 105 | ; ] 106 | 107 | ;;Monadic lifting operators 108 | liftM: function [ 109 | "Promote a function to a monad." 110 | f [any-function!] 111 | mx [object! series!] 112 | ][ 113 | mx >>= (function [x] [liftM* mx :f x]) 114 | ] 115 | 116 | liftM*: function [ 117 | mx [object! series!] 118 | f [any-function!] 119 | x 120 | ][ 121 | case [ 122 | (object? mx) (liftM-object* mx :f x) 123 | (series? mx) (liftM-series* mx :f x) 124 | ] 125 | ] 126 | 127 | liftM-object*: function [ 128 | mx [object!] 129 | f [any-function!] 130 | x 131 | ][ 132 | case [ 133 | ((isJust mx) || (isNothing mx)) (Just (f x)) 134 | ((isLeft mx) || (isRight mx)) (Right (f x)) 135 | ] 136 | ] 137 | 138 | liftM-series*: function [ 139 | mx [series!] 140 | f [any-function!] 141 | x 142 | ][ 143 | either (string? mx) [to-string f x][reduce [f x]] 144 | ] 145 | 146 | liftM2: function [ 147 | "Promote a function to a monad, scanning the monadic arguments from left to right." 148 | f [any-function!] 149 | mx [object! series!] 150 | my [object! series!] 151 | ][ 152 | ;;function [x] reduce ['function [y] 'reduce ['add :x 'y] ] 153 | g: (function [x] reduce ['function [y] 'reduce ['f :x 'y]]) 154 | print mold :g 155 | h: function [x][g x] 156 | ;print mold :h 157 | ;i: h 2 158 | ;print mold (i 2) 159 | ;print mold :i 160 | 161 | s: (liftM :g [1 2]) 162 | print mold :s 163 | [] 164 | ;my >>= :fs 165 | ] 166 | 167 | ; liftM2*: function [ 168 | ; mx [object! series!] 169 | ; f [any-function!] 170 | ; x 171 | ; y 172 | ; ][ 173 | ; case [ 174 | ; (object? mx) (liftM-object* mx :f x) 175 | ; (series? mx) (liftM-series* mx :f x) 176 | ; ] 177 | ; ] 178 | 179 | ; liftM-object*: function [ 180 | ; mx [object!] 181 | ; f [any-function!] 182 | ; x 183 | ; y 184 | ; ][ 185 | ; case [ 186 | ; ((isJust mx) || (isNothing mx)) (Just (f x)) 187 | ; ((isLeft mx) || (isRight mx)) (Right (f x)) 188 | ; ] 189 | ; ] 190 | 191 | ; liftM-series*: function [ 192 | ; mx [series!] 193 | ; f [any-function!] 194 | ; x 195 | ; y 196 | ; ][ 197 | ; either (string? mx) [to-string f x][reduce [f x]] 198 | ; ] -------------------------------------------------------------------------------- /data-char-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Char test script" 3 | Author: "unchartedworks" 4 | File: %data-char-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %data-char.red 13 | 14 | ~~~start-file~~~ "data-char" 15 | lowercaseLetters: "abcdefghijklmnopqrstuvwxyz" 16 | uppercaseLetters: "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 17 | digits: "0123456789" 18 | octDigits: "01234567" 19 | hexDigits: "0123456789ABCDEFabcdef" 20 | punctuations: "!^"#$%&'()*+,-./:;<=>?@[\]^^_`{|}~" 21 | 22 | ===start-group=== "isControl" 23 | --test-- "char! -> logic! 1" 24 | y: false 25 | z: isControl #"a" 26 | --assert* [y == z] 27 | 28 | --test-- "char! -> logic! 2" 29 | y: true 30 | z: isControl #"^/" 31 | --assert* [y == z] 32 | 33 | --test-- "char! -> logic! 3" 34 | y: true 35 | z: isControl #"^(esc)" 36 | --assert* [y == z] 37 | ===end-group=== 38 | 39 | ===start-group=== "isSpace" 40 | --test-- "char! -> logic! 1" 41 | y: false 42 | z: isSpace #"a" 43 | --assert* [y == z] 44 | 45 | --test-- "char! -> logic! 2" 46 | y: true 47 | z: isSpace space 48 | --assert* [y == z] 49 | 50 | --test-- "char! -> logic! 3" 51 | y: true 52 | z: isSpace #"^(tab)" 53 | --assert* [y == z] 54 | ===end-group=== 55 | 56 | ===start-group=== "isLower" 57 | --test-- "char! -> logic! 1" 58 | y: false 59 | z: all' :isLower uppercaseLetters 60 | --assert* [y == z] 61 | 62 | --test-- "char! -> logic! 2" 63 | y: true 64 | z: all' :isLower lowercaseLetters 65 | --assert* [y == z] 66 | ===end-group=== 67 | 68 | ===start-group=== "isUpper" 69 | --test-- "char! -> logic! 1" 70 | y: true 71 | z: all' :isUpper uppercaseLetters 72 | --assert* [y == z] 73 | 74 | --test-- "char! -> logic! 2" 75 | y: false 76 | z: all' :isUpper lowercaseLetters 77 | --assert* [y == z] 78 | ===end-group=== 79 | 80 | ===start-group=== "isAlpha" 81 | --test-- "char! -> logic! 1" 82 | y: true 83 | z: all' :isAlpha uppercaseLetters 84 | --assert* [y == z] 85 | 86 | --test-- "char! -> logic! 2" 87 | y: true 88 | z: all' :isAlpha lowercaseLetters 89 | --assert* [y == z] 90 | 91 | --test-- "char! -> logic! 3" 92 | y: false 93 | z: all' :isAlpha digits 94 | --assert* [y == z] 95 | ===end-group=== 96 | 97 | ===start-group=== "isAlphaNum" 98 | --test-- "char! -> logic! 1" 99 | y: true 100 | z: all' :isAlphaNum uppercaseLetters 101 | --assert* [y == z] 102 | 103 | --test-- "char! -> logic! 2" 104 | y: true 105 | z: all' :isAlphaNum lowercaseLetters 106 | --assert* [y == z] 107 | 108 | --test-- "char! -> logic! 3" 109 | y: true 110 | z: all' :isAlphaNum digits 111 | --assert* [y == z] 112 | 113 | --test-- "char! -> logic! 4" 114 | y: false 115 | z: all' :isAlphaNum [#" " #"^\"] 116 | --assert* [y == z] 117 | ===end-group=== 118 | 119 | ===start-group=== "isDigit" 120 | --test-- "char! -> logic! 1" 121 | y: true 122 | z: all' :isDigit digits 123 | --assert* [y == z] 124 | 125 | --test-- "char! -> logic! 2" 126 | y: false 127 | z: all' :isDigit lowercaseLetters 128 | --assert* [y == z] 129 | 130 | --test-- "char! -> logic! 3" 131 | y: false 132 | z: all' :isDigit uppercaseLetters 133 | --assert* [y == z] 134 | ===end-group=== 135 | 136 | ===start-group=== "isOctDigit" 137 | --test-- "char! -> logic! 1" 138 | y: true 139 | z: all' :isOctDigit octDigits 140 | --assert* [y == z] 141 | 142 | --test-- "char! -> logic! 2" 143 | y: false 144 | z: all' :isOctDigit digits 145 | --assert* [y == z] 146 | 147 | --test-- "char! -> logic! 3" 148 | y: false 149 | z: all' :isOctDigit hexDigits 150 | --assert* [y == z] 151 | ===end-group=== 152 | 153 | ===start-group=== "isHexDigit" 154 | --test-- "char! -> logic! 1" 155 | y: true 156 | z: all' :isHexDigit hexDigits 157 | --assert* [y == z] 158 | 159 | --test-- "char! -> logic! 2" 160 | y: false 161 | z: all' :isOctDigit lowercaseLetters 162 | --assert* [y == z] 163 | 164 | --test-- "char! -> logic! 3" 165 | y: false 166 | z: all' :isOctDigit uppercaseLetters 167 | --assert* [y == z] 168 | ===end-group=== 169 | 170 | ===start-group=== "isLetter" 171 | --test-- "char! -> logic! 1" 172 | y: true 173 | z: all' :isLetter uppercaseLetters 174 | --assert* [y == z] 175 | 176 | --test-- "char! -> logic! 2" 177 | y: true 178 | z: all' :isLetter lowercaseLetters 179 | --assert* [y == z] 180 | 181 | --test-- "char! -> logic! 3" 182 | y: false 183 | z: all' :isLetter digits 184 | --assert* [y == z] 185 | ===end-group=== 186 | 187 | ===start-group=== "isPunctuation" 188 | --test-- "char! -> logic! 1" 189 | y: true 190 | z: all' :isPunctuation punctuations 191 | --assert* [y == z] 192 | 193 | --test-- "char! -> logic! 2" 194 | y: false 195 | z: all' :isPunctuation lowercaseLetters 196 | --assert* [y == z] 197 | 198 | --test-- "char! -> logic! 3" 199 | y: false 200 | z: all' :isPunctuation digits 201 | --assert* [y == z] 202 | ===end-group=== 203 | 204 | ===start-group=== "isSeparator" 205 | --test-- "char! -> logic! 1" 206 | y: true 207 | z: all' :isSeparator [#" " #"^-" #"^M" #"^/" #"^K" #"^L"] 208 | --assert* [y == z] 209 | 210 | --test-- "char! -> logic! 2" 211 | y: false 212 | z: all' :isPunctuation lowercaseLetters 213 | --assert* [y == z] 214 | 215 | --test-- "char! -> logic! 3" 216 | y: false 217 | z: all' :isPunctuation digits 218 | --assert* [y == z] 219 | ===end-group=== 220 | 221 | ===start-group=== "isAsciiLower" 222 | --test-- "char! -> logic! 1" 223 | y: false 224 | z: all' :isAsciiLower uppercaseLetters 225 | --assert* [y == z] 226 | 227 | --test-- "char! -> logic! 2" 228 | y: true 229 | z: all' :isAsciiLower lowercaseLetters 230 | --assert* [y == z] 231 | ===end-group=== 232 | 233 | ===start-group=== "isAsciiUpper" 234 | --test-- "char! -> logic! 1" 235 | y: true 236 | z: all' :isAsciiUpper uppercaseLetters 237 | --assert* [y == z] 238 | 239 | --test-- "char! -> logic! 2" 240 | y: false 241 | z: all' :isAsciiUpper lowercaseLetters 242 | --assert* [y == z] 243 | ===end-group=== 244 | 245 | ===start-group=== "toUpper" 246 | --test-- "char! -> char! 1" 247 | y: #"A" 248 | z: toUpper #"a" 249 | --assert* [y == z] 250 | 251 | --test-- "char! -> char! 2" 252 | y: uppercaseLetters 253 | z: map :toUpper lowercaseLetters 254 | --assert* [y == z] 255 | 256 | --test-- "string! -> string!" 257 | y: uppercaseLetters 258 | z: toUpper lowercaseLetters 259 | --assert* [y == z] 260 | ===end-group=== 261 | 262 | ===start-group=== "toLower" 263 | --test-- "char! -> char! 1" 264 | y: #"a" 265 | z: toLower #"A" 266 | --assert* [y == z] 267 | 268 | --test-- "char! -> char! 2" 269 | y: lowercaseLetters 270 | z: map :toLower uppercaseLetters 271 | --assert* [y == z] 272 | 273 | --test-- "string! -> string!" 274 | y: lowercaseLetters 275 | z: toLower uppercaseLetters 276 | --assert* [y == z] 277 | ===end-group=== 278 | 279 | ===start-group=== "digitToInt" 280 | --test-- "char! -> integer! 1" 281 | y: [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 10 11 12 13 14 15] 282 | z: map :digitToInt hexDigits 283 | --assert* [y == z] 284 | 285 | --test-- "char! -> integer! 2" 286 | y: none 287 | z: attempt [digitToInt #"g"] 288 | --assert* [y == z] 289 | ===end-group=== 290 | 291 | ===start-group=== "intToDigit" 292 | --test-- "integer! -> char! 1" 293 | xs: [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 10 11 12 13 14 15] 294 | ys: "0123456789abcdef" 295 | zs: map :intToDigit xs 296 | --assert* [y == z] 297 | 298 | --test-- "integer! -> char! 1" 299 | y: none 300 | z: attempt [intToDigit 20] 301 | --assert* [y == z] 302 | ===end-group=== 303 | 304 | ===start-group=== "ord" 305 | --test-- "integer! -> char! 1" 306 | y: 97 307 | z: ord #"a" 308 | --assert* [y == z] 309 | 310 | --test-- "integer! -> char! 1" 311 | y: 65 312 | z: ord #"A" 313 | --assert* [y == z] 314 | ===end-group=== 315 | 316 | ===start-group=== "chr" 317 | --test-- "integer! -> char! 1" 318 | y: #"a" 319 | z: chr 97 320 | --assert* [y == z] 321 | 322 | --test-- "integer! -> char! 1" 323 | y: #"B" 324 | z: chr 66 325 | --assert* [y == z] 326 | ===end-group=== 327 | ~~~end-file~~~ -------------------------------------------------------------------------------- /data-char.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Char" 3 | Author: "unchartedworks" 4 | File: %data-char.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %prelude.red 11 | 12 | isControl: function [ 13 | "These characters are specifically the Unicode values U+0000 to U+001F and U+007F to U+009F." 14 | c [char!] 15 | ][ 16 | n: (to-hex to-integer c) 17 | ((#00000000 <= n) && (n <= #0000001f)) || ((#0000007f <= n) && (n <= #0000009f)) 18 | ] 19 | 20 | isSpace: function [ 21 | "a character set containing only the in-line whitespace characters space (U+0020) and tab (U+0009)." 22 | c [char!] 23 | ][ 24 | (c == #" ") || (c == #"^-") || (c == #"^M") || (c == #"^/") || (c == #"^K") || (c == #"^L") 25 | ] 26 | 27 | isLower: function [ 28 | "a character set containing only the in-line lowercase characters." 29 | c [char!] 30 | ][ 31 | (c <= #"z") && (c >= #"a") 32 | ] 33 | 34 | isUpper: function [ 35 | "a character set containing only the in-line uppercase characters." 36 | c [char!] 37 | ][ 38 | (c <= #"Z") && (c >= #"A") 39 | ] 40 | 41 | isAlpha: function [ 42 | "a character set containing only the letter characters." 43 | c [char!] 44 | ][ 45 | (isLower c) || (isUpper c) 46 | ] 47 | 48 | isAlphaNum: function [ 49 | "a character set containing only the letter and digit characters." 50 | c [char!] 51 | ][ 52 | (isAlpha c) || (isDigit c) 53 | ] 54 | 55 | isPrint: function [ 56 | "a character set containing only the printable characters." 57 | c [char!] 58 | ][ 59 | (isLower c) || (isUpper c) 60 | ] 61 | 62 | isDigit: function [ 63 | "a character set containing only the digit characters." 64 | c [char!] 65 | ][ 66 | (c <= #"9") && (c >= #"0") 67 | ] 68 | 69 | isOctDigit: function [ 70 | "a character set containing only the oct digit characters." 71 | c [char!] 72 | ][ 73 | (c <= #"7") && (c >= #"0") 74 | ] 75 | 76 | isHexDigit: function [ 77 | "a character set containing only the hex digit characters." 78 | c [char!] 79 | ][ 80 | elem c "0123456789ABCDEFabcdef" 81 | ] 82 | 83 | isLetter: function [ 84 | "a character set containing only the letter characters." 85 | c [char!] 86 | ][ 87 | isAlpha c 88 | ] 89 | 90 | isPunctuation: function [ 91 | "Selects Unicode punctuation characters, including various kinds of connectors, brackets and quotes. It's not finished yet." 92 | "This function returns True if its argument has one of the Category, or False otherwise" 93 | c [char!] 94 | ][ 95 | punctuations: "!^"#$%&'()*+,-./:;<=>?@[\]^^_`{|}~" 96 | elem c punctuations 97 | ] 98 | 99 | isSeparator: function [ 100 | "This function returns True if its argument has one of Space, LineSeparator, ParagraphSeparator" 101 | c [char!] 102 | ][ 103 | n: (to-hex to-integer c) 104 | (isSpace c) || (n == #00002028) || (n == #00002029) 105 | ] 106 | 107 | isAscii: function [ 108 | "Selects the first 128 characters of the Unicode character set, corresponding to the ASCII character set." 109 | c [char!] 110 | ][ 111 | n: (to-hex to-integer c) 112 | c < #00000080 113 | ] 114 | 115 | isLatin1: function [ 116 | "Selects the first 256 characters of the Unicode character set, corresponding to the ASCII character set." 117 | c [char!] 118 | ][ 119 | n: (to-hex to-integer c) 120 | c < #00000100 121 | ] 122 | 123 | isAsciiLower: function [ 124 | "a character set containing only the in-line lowercase characters." 125 | c [char!] 126 | ][ 127 | (c <= #"z") && (c >= #"a") 128 | ] 129 | 130 | isAsciiUpper: function [ 131 | "a character set containing only the in-line uppercase characters." 132 | c [char!] 133 | ][ 134 | (c <= #"Z") && (c >= #"A") 135 | ] 136 | 137 | toUpper: function [ 138 | "Convert a letter to the corresponding upper-case letter, if any. Any other character is returned unchanged." 139 | c' [char! string!] 140 | ][ 141 | c: either (char? c') [c'][copy c'] 142 | uppercase c 143 | ] 144 | 145 | toLower: function [ 146 | "Convert a letter to the corresponding lower-case letter, if any. Any other character is returned unchanged." 147 | c' [char! string!] 148 | ][ 149 | c: either (char? c') [c'][copy c'] 150 | lowercase c 151 | ] 152 | 153 | 154 | digitToInt: function [ 155 | "Convert a single digit Char to the corresponding Int. This function fails unless its argument satisfies isHexDigit, but recognises both upper- and lower-case hexadecimal digits (that is, '0'..'9', 'a'..'f', 'A'..'F')." 156 | c [char!] 157 | ][ 158 | case [ 159 | (isDigit c) ((to-integer c) - (to-integer #"0")) 160 | ((#"a" <= c) && (c <= #"f")) ((to-integer c) - (to-integer #"a") + 10) 161 | ((#"A" <= c) && (c <= #"F")) ((to-integer c) - (to-integer #"A") + 10) 162 | true (cause-error 'script 'invalid-arg [c]) 163 | ] 164 | ] 165 | 166 | intToDigit: function [ 167 | "Convert an Int in the range 0..15 to the corresponding single digit Char. This function fails on other inputs, and generates lower-case hexadecimal digits." 168 | x [integer!] 169 | ][ 170 | case [ 171 | ((0 <= x) && (x <= 9)) (to-char (x + (to-integer #"0"))) 172 | ((10 <= x) && (x < 16)) (to-char (x + (to-integer #"a"))) 173 | true (cause-error 'script 'invalid-arg [x]) 174 | ] 175 | ] 176 | 177 | ord: :to-integer 178 | 179 | chr: :to-char -------------------------------------------------------------------------------- /data-either-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Either test script" 3 | Author: "unchartedworks" 4 | File: %data-either-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %prelude.red 13 | #include %data-list.red 14 | #include %data-function.red 15 | #include %data-either.red 16 | 17 | ~~~start-file~~~ "data-either" 18 | ===start-group=== "Left" 19 | --test-- "integer! -> Either integer! b" 20 | y: Left 1 21 | z: Left 1 22 | --assert* [y == z] 23 | 24 | --test-- "string! -> Either string! b" 25 | y: Left "abc" 26 | z: Left "abc" 27 | --assert* [y == z] 28 | ===end-group=== 29 | 30 | ===start-group=== "Right" 31 | --test-- "integer! -> Either a integer!" 32 | y: Right 1 33 | z: Right 1 34 | --assert* [y == z] 35 | 36 | --test-- "string! -> Either a string!" 37 | y: Right "abc" 38 | z: Right "abc" 39 | --assert* [y == z] 40 | ===end-group=== 41 | 42 | ===start-group=== "isLeft" 43 | --test-- "Left integer! b -> logic!" 44 | y: true 45 | z: isLeft Left 3 46 | --assert* [y == z] 47 | 48 | --test-- "Left string! b -> logic!" 49 | y: true 50 | z: isLeft Left "red" 51 | --assert* [y == z] 52 | 53 | --test-- "Right a integer -> logic!" 54 | y: false 55 | z: isLeft Right 3 56 | --assert* [y == z] 57 | 58 | --test-- "Right a string -> logic!" 59 | y: false 60 | z: isLeft Right "abc" 61 | --assert* [y == z] 62 | ===end-group=== 63 | 64 | ===start-group=== "isRight" 65 | --test-- "Left integer! b -> logic!" 66 | y: false 67 | z: isRight Left 3 68 | --assert* [y == z] 69 | 70 | --test-- "Left string! b -> logic!" 71 | y: false 72 | z: isRight Left "red" 73 | --assert* [y == z] 74 | 75 | --test-- "Right a integer! -> logic!" 76 | y: true 77 | z: isRight Right 3 78 | --assert* [y == z] 79 | 80 | --test-- "Right a string! -> logic!" 81 | y: true 82 | z: isRight Right "abc" 83 | --assert* [y == z] 84 | ===end-group=== 85 | 86 | ===start-group=== "fromLeft" 87 | --test-- "Left integer! b -> integer!" 88 | y: 3 89 | z: fromLeft Left 3 90 | --assert* [y == z] 91 | 92 | --test-- "Left string! b -> integer!" 93 | y: "red" 94 | z: fromLeft Left "red" 95 | --assert* [y == z] 96 | 97 | --test-- "Right integer! -> logic!" 98 | y: none 99 | z: attempt [fromLeft Right 3] 100 | --assert* [y == z] 101 | 102 | --test-- "Right string! -> logic!" 103 | y: none 104 | z: attempt [fromLeft Right "abc"] 105 | --assert* [y == z] 106 | ===end-group=== 107 | 108 | ===start-group=== "fromRight" 109 | --test-- "Right integer! b -> integer!" 110 | y: 3 111 | z: fromRight Right 3 112 | --assert* [y == z] 113 | 114 | --test-- "Right string! b -> integer!" 115 | y: "red" 116 | z: fromRight Right "red" 117 | --assert* [y == z] 118 | 119 | --test-- "Left integer! -> logic!" 120 | y: none 121 | z: attempt [fromRight Left 3] 122 | --assert* [y == z] 123 | 124 | --test-- "Left string! -> logic!" 125 | y: none 126 | z: attempt [fromRight Left "abc"] 127 | --assert* [y == z] 128 | ===end-group=== 129 | 130 | ===start-group=== "partitionEithers" 131 | --test-- "[Either string! integer!] -> [[string!] [integer!]] 1" 132 | xs: [Left 1 Right "A" Left 2 Right "B"] 133 | ys: [[1 2] ["A" "B"]] 134 | zs: partitionEithers xs 135 | --assert* [ys == zs] 136 | 137 | --test-- "[Either string! integer!] -> [[string!] [integer!]] 2" 138 | xs: [Left 1 Left 2] 139 | ys: [[1 2] []] 140 | zs: partitionEithers xs 141 | --assert* [ys == zs] 142 | ===end-group=== 143 | 144 | ===start-group=== "either'" 145 | --test-- "Either integer! string! -> integer!" 146 | f: [x] -> [x + 1] 147 | g: [y] -> [uppercase y] 148 | y: 4 149 | z: either' :f :g (Left 3) 150 | --assert* [y == z] 151 | 152 | --test-- "Either integer! string! -> string!" 153 | f: [x] -> [x + 1] 154 | g: [y] -> [uppercase y] 155 | y: "ABC" 156 | z: either' :f :g (Right "abc") 157 | --assert* [y == z] 158 | 159 | ===end-group=== 160 | 161 | ~~~end-file~~~ -------------------------------------------------------------------------------- /data-either.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Either" 3 | Author: "unchartedworks" 4 | File: %data-either.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | Left: [x] -> [make object! [type: 'Left value: x]] 11 | Right: [x] -> [make object! [type: 'Right value: x]] 12 | 13 | either': [ 14 | "Case analysis for the Either type. If the value is Left a, apply the first function to a; if it is Right b, apply the second function to b." 15 | f [any-function!] 16 | g [any-function!] 17 | mx [object!] 18 | ] -> [ 19 | case [ 20 | (isLeft mx) (f fromLeft) 21 | (isRight mx) (f fromRight) 22 | otherwise (cause-error 'script 'invalid-arg [mx]) 23 | ] 24 | ] 25 | 26 | isLeft: [ 27 | "Return True if the given value is a Left-value, False otherwise." 28 | x [object!] 29 | ] -> [x/type == 'Left] 30 | 31 | isRight: [ 32 | "Return True if the given value is a Right-value, False otherwise." 33 | x [object!] 34 | ] -> [x/type == 'Right] 35 | 36 | fromLeft: [ 37 | "Return the contents of a Left-value or a default value otherwise." 38 | mx [object!] 39 | ] -> [ 40 | either (isLeft mx) [mx/value] [cause-error 'script 'invalid-arg [mx]] 41 | ] 42 | 43 | fromRight: [ 44 | "Return the contents of a Right-value or a default value otherwise." 45 | mx [object!] 46 | ] -> [ 47 | either (isRight mx) [mx/value] [cause-error 'script 'invalid-arg [mx]] 48 | ] 49 | 50 | partitionEithers: [ 51 | "Partitions a list of Either into two lists. All the Left elements are extracted, in order, to the first component of the output. Similarly the Right elements are extracted to the second component of the output." 52 | mxs' [series!] 53 | ] -> [ 54 | mxs: reduce mxs' 55 | xs: reduce [map :fromLeft (filter :isLeft mxs)] 56 | ys: reduce [map :fromRight (filter :isRight mxs)] 57 | reduce xs ++ ys 58 | ] 59 | 60 | either': function [ 61 | "Case analysis for the Either type. If the value is Left a, apply the first function to a; if it is Right b, apply the second function to b." 62 | f [any-function!] 63 | g [any-function!] 64 | mx [object!] 65 | ][ 66 | case [ 67 | (isLeft mx) (f (fromLeft mx)) 68 | (isRight mx) (g (fromRight mx)) 69 | otherwise (cause-error 'script 'invalid-arg [mx]) 70 | ] 71 | ] -------------------------------------------------------------------------------- /data-function-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.List test script" 3 | Author: "unchartedworks" 4 | File: %data-list-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %data-list.red 13 | #include %data-function.red 14 | 15 | ~~~start-file~~~ "data-function" 16 | 17 | ===start-group=== "->" 18 | 19 | --test-- "block! -> block! -> function! 1" 20 | f: [x] -> [x + 1] 21 | g: function [x][x + 1] 22 | --assert* [(mold :f) == (mold :g)] 23 | 24 | --test-- "block! -> block! -> function! 2" 25 | f: [x y] -> [x + y] 26 | g: function [x y][x + y] 27 | --assert* [(mold :f) == (mold :g)] 28 | 29 | --test-- "block! -> block! -> function! 3" 30 | f: [x] -> [y: 1 (x + y)] 31 | g: function [x][y: 1 (x + y)] 32 | --assert* [(mold :f) == (mold :g)] 33 | 34 | --test-- "block! -> block! -> function! 4" 35 | f: [x y] -> [z: 1 (x + y + z)] 36 | g: function [x y][z: 1 (x + y + z)] 37 | --assert* [(mold :f) == (mold :g)] 38 | 39 | ===end-group=== 40 | 41 | ===start-group=== "id" 42 | --test-- "integer! -> string!" 43 | xs: 1 44 | ys: 1 45 | zs: id xs 46 | --assert* [ys == zs] 47 | 48 | --test-- "string! -> string!" 49 | xs: "abc" 50 | ys: "abc" 51 | zs: id xs 52 | --assert* [ys == zs] 53 | 54 | --test-- "word! -> word!" 55 | xs: 'x 56 | ys: 'x 57 | zs: id xs 58 | --assert* [ys == zs] 59 | 60 | --test-- "function! -> function!" 61 | xs: func [x][x + 1] 62 | ys: mold func [x][x + 1] 63 | zs: mold (id :xs) 64 | --assert* [ys == zs] 65 | 66 | --test-- "[integer!] -> [integer!]" 67 | xs: [1 2 3] 68 | ys: [1 2 3] 69 | zs: id xs 70 | --assert* [ys == zs] 71 | ===end-group=== 72 | 73 | ===start-group=== "const" 74 | --test-- "integer! -> integer! -> string!" 75 | xs: 1 76 | ys: 1 77 | zs: const xs 3 78 | --assert* [ys == zs] 79 | 80 | --test-- "string! -> integer! -> string!" 81 | xs: "abc" 82 | ys: "abc" 83 | zs: const xs 8 84 | --assert* [ys == zs] 85 | 86 | --test-- "word! -> string! -> word!" 87 | xs: 'x 88 | ys: 'x 89 | zs: const xs "ab" 90 | --assert* [ys == zs] 91 | 92 | --test-- "any-function! -> any-function! -> any-function!" 93 | xs: func [x][x + 1] 94 | ys: mold func [x][x + 1] 95 | zs: mold (const :xs :positive?) 96 | --assert* [ys == zs] 97 | 98 | --test-- "[integer!] -> integer! -> [integer!]" 99 | xs: [1 2 3] 100 | ys: [1 2 3] 101 | zs: const xs 9 102 | --assert* [ys == zs] 103 | ===end-group=== 104 | 105 | ===start-group=== "." 106 | --test-- "(integer! -> integer!) -> (integer! -> integer!) -> (integer! -> integer!) 1" 107 | f1: func [x][x + 1] 108 | f2: func [x][x * 2] 109 | f: :f1 . :f2 110 | ys: 7 111 | zs: f 3 112 | --assert* [ys == zs] 113 | 114 | --test-- "(integer! -> integer!) -> (integer! -> integer!) -> (integer! -> integer!) 2" 115 | f1: func [x][x + 1] 116 | f2: func [x][x * 2] 117 | f: :f1 . :f2 . :f2 . :f2 118 | ys: 25 119 | zs: f 3 120 | --assert* [ys == zs] 121 | 122 | --test-- "(string! -> integer!) -> (integer! -> integer!) -> (string! -> integer!) 1" 123 | f1: func [x][x * 2] 124 | f2: func [x][length? x] 125 | f: :f1 . :f2 126 | ys: 6 127 | zs: f "abc" 128 | --assert* [ys == zs] 129 | 130 | --test-- "(string! -> integer!) -> (integer! -> integer!) -> (string! -> integer!) 2" 131 | f1: func [x][x * 2] 132 | f2: func [x][length? x] 133 | f: :f1 . :f1 . :f1 . :f2 134 | ys: 24 135 | zs: f "abc" 136 | --assert* [ys == zs] 137 | 138 | ===end-group=== 139 | 140 | ===start-group=== "flip" 141 | --test-- "integer! -> integer! -> logic! -> integer! -> integer!" 142 | ys: true 143 | zs: flip func [x y][x > y] 1 2 144 | --assert* [ys == zs] 145 | 146 | --test-- "string! -> integer! -> logic! -> integer! -> string!" 147 | ys: true 148 | zs: flip func [s x][(length? s) > x] 1 "abc" 149 | --assert* [ys == zs] 150 | 151 | ===end-group=== 152 | 153 | ===start-group=== "&" 154 | --test-- "[integer!] -> function! -> [string!]" 155 | f: function [x][x + 1] 156 | x: 3 157 | y: 4 158 | z: x & :f 159 | --assert* [y == z] 160 | 161 | --test-- "[integer!] -> [function!] -> [string!]" 162 | to-charint: [x] -> [to-integer #"a" + x] 163 | to-strings: [xs] -> [map (:to-string . :to-char . :to-charint) xs] 164 | ys: "ABCD" 165 | zs: [0 1 2 3] & :to-strings & :concat & :uppercase 166 | --assert* [ys == zs] 167 | 168 | ===end-group=== 169 | 170 | ===start-group=== ">>>=" 171 | --test-- "integer! -> [function!] -> integer!" 172 | f: function [x][x + 1] 173 | x: 3 174 | y: 4 175 | z: x >>>= [f] 176 | --assert* [y == z] 177 | 178 | --test-- "[integer!] -> [any-function!] -> [string!]" 179 | to-charints: [xs] -> [map ([x] -> [to-integer #"a" + x]) xs] 180 | to-chars: [xs] -> [map :to-char xs] 181 | to-strings: function [xs][map :to-string xs] 182 | ys: "ABCD" 183 | zs: [0 1 2 3] >>>= [to-charints to-chars to-strings concat uppercase] 184 | --assert* [ys == zs] 185 | 186 | --test-- "path! -> [any-function!] -> integer!" 187 | file-path: %data-function-test.red 188 | y: 1 189 | z: file-path >>>= [read/lines length?] 190 | --assert* [y < z] 191 | 192 | ===end-group=== 193 | 194 | ~~~end-file~~~ -------------------------------------------------------------------------------- /data-function.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Function" 3 | Author: "unchartedworks" 4 | File: %data-function.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | ->: make op! :function 11 | 12 | id: function [ 13 | "Identity function" 14 | x 15 | ][ 16 | :x 17 | ] 18 | 19 | const: function [ 20 | "a unary function which evaluates to x for all inputs." 21 | x 22 | y 23 | ][ 24 | :x 25 | ] 26 | 27 | compose-function*: function [ 28 | f [any-function!] 29 | g [any-function!] 30 | ][ 31 | func [x] reduce [:f :g 'x] 32 | ] 33 | .: make op! :compose-function* 34 | 35 | flip: function [ 36 | f [any-function!] 37 | b 38 | a 39 | ][ 40 | f a b 41 | ] 42 | 43 | postfix: function [ 44 | "a reverse application operator. This provides notational convenience." 45 | x f 46 | ][ 47 | f x 48 | ] 49 | &: make op! :postfix -------------------------------------------------------------------------------- /data-list.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.List" 3 | Author: "unchartedworks" 4 | File: %data-list.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | ;;++ 11 | plus-block: function [ 12 | xs [block! string!] 13 | ys [block! string!] 14 | ][ 15 | append copy reduce xs reduce ys 16 | ] 17 | 18 | reduce-deep: function [ 19 | xs' 20 | ] [ 21 | xs: reduce xs' 22 | case [ 23 | (not block? xs) xs 24 | (all [block? xs empty? xs]) xs 25 | (all [block? xs not empty? xs]) map :reduce-deep xs 26 | ] 27 | ] 28 | ++: make op! :plus-block 29 | 30 | head': :first 31 | last': :last 32 | 33 | rest: function [ 34 | "Extract the elements after the head of a list, which must be non-empty." 35 | xs [series!] 36 | ][ 37 | copy next xs 38 | ] 39 | tail': :rest 40 | 41 | init: function [ 42 | "Return all the elements of a list except the last one. The list must be non-empty." 43 | xs [series!] 44 | ][ 45 | either 1 == length? xs [ 46 | either string? xs [copy ""][copy []] 47 | ][ 48 | copy/part xs ((length? xs) - 1) 49 | ] 50 | ] 51 | most: :init 52 | 53 | uncons: function [ 54 | "Decompose a list into its first and rest. If the list is empty, returns Nothing. If the list is non-empty, returns Just (x, xs), where x is the head of the list and xs its tail." 55 | xs [series!] 56 | ][ 57 | either empty? xs [ 58 | none 59 | ][ 60 | reduce [first xs (rest xs)] 61 | ] 62 | ] 63 | 64 | length: function [ 65 | "Returns the size/length of a finite structure as an Int. The default implementation is optimized for structures that are similar to cons-lists, because there is no general way to do better." 66 | xs [series!] 67 | ][ 68 | length? xs 69 | ] 70 | 71 | map: function [ 72 | "applying f to each element of xs" 73 | f [any-function!] 74 | xs [series!] 75 | ][ 76 | yss: copy [] 77 | g: function [ys x] [ys ++ (reduce [f x])] 78 | zss: foldl :g yss xs 79 | should-concat: and' [(string? xs) and' (map :char? zss)] 80 | either should-concat [ 81 | accum: func[y x][y ++ (to-string x)] 82 | foldl :accum "" zss 83 | ][ 84 | zss 85 | ] 86 | ] 87 | 88 | reverse': function [ 89 | "returns the elements of xs in reverse order." 90 | xs [series!] 91 | ][ 92 | reverse copy xs 93 | ] 94 | 95 | intersperse: function [ 96 | "taking an element and a list and `intersperses' that element between the elements of the list." 97 | y 98 | xs [series!] 99 | ][ 100 | either 1 >= length? xs [xs][intersperse* y xs] 101 | ] 102 | 103 | intersperse*: function [ 104 | y 105 | xs [series!] 106 | ][ 107 | r: either string? xs [copy ""][copy []] 108 | f: func [ys x][ys ++ (reduce [x y])] 109 | ys: foldl :f r (most reduce xs) 110 | zs: reduce [last reduce xs] 111 | ys ++ zs 112 | ] 113 | 114 | transpose: function [ 115 | "transposing the rows and columns of its argument." 116 | xss [series!] 117 | ][ 118 | case [ 119 | (not transposable? xss) none 120 | empty? xss [copy []] 121 | (empty? first xss) (copy []) 122 | true (append (copy reduce [map :first xss]) (transpose map :rest xss)) 123 | ] 124 | ] 125 | 126 | transposable?: function [ 127 | xss [series!] 128 | ][ 129 | case [ 130 | (xss == []) true 131 | true == (all (map func [x][all [block? x empty? x]] xss)) true 132 | none == (all (map :block? xss)) false 133 | (transposable?* xss) true 134 | true false 135 | ] 136 | ] 137 | 138 | transposable?*: function [ 139 | xss [series!] 140 | ][ 141 | general-length?: func [x][either (series? x) [length? x][none]] 142 | length-equal?: func [x][(general-length? x) == (general-length? first :xss)] 143 | 144 | none <> all [ 145 | (block? xss) 146 | all (map :block? xss) 147 | all (map :length-equal? xss) 148 | ] 149 | ] 150 | 151 | subsequences: function [ 152 | "returns the list of all subsequences of the argument" 153 | xs [series!] 154 | ][ 155 | case [ 156 | (not series? xs) none 157 | (empty? xs) (reduce [xs]) 158 | (block? xs) (block-subsequences xs) 159 | (string? xs) ([""] ++ (string-subsequences xs)) 160 | ] 161 | ] 162 | 163 | block-subsequences: function [ 164 | xs 165 | ][ 166 | either (empty? xs) [ 167 | copy [[]] 168 | ][ 169 | append (copy [[]]) non-empty-block-subsequences xs 170 | ] 171 | ] 172 | 173 | non-empty-block-subsequences: function [ 174 | xs 175 | ][ 176 | either empty? xs [copy []][non-empty-block-subsequences* xs] 177 | ] 178 | 179 | non-empty-block-subsequences*: function [ 180 | xs 181 | ][ 182 | g: function [ys r][ 183 | m1: reduce [ys] 184 | m2: reduce [(reduce [first xs]) ++ ys] 185 | m3: r 186 | (m1 ++ m2) ++ m3 187 | ] 188 | 189 | r0: (reduce [reduce [first xs]]) 190 | r1: foldr :g [] (non-empty-block-subsequences (rest xs)) 191 | 192 | r0 ++ r1 193 | ] 194 | 195 | string-subsequences: function [ 196 | xs [string!] 197 | ][ 198 | either (empty? xs) [ 199 | copy [""] 200 | ][ 201 | non-empty-string-subsequences xs 202 | ] 203 | ] 204 | 205 | non-empty-string-subsequences: function [ 206 | xs [string!] 207 | ][ 208 | either empty? xs [copy []][non-empty-string-subsequences* xs] 209 | ] 210 | 211 | non-empty-string-subsequences*: function [ 212 | xs [string!] 213 | ][ 214 | g: function [ys r][ 215 | m1: reduce [ys] 216 | m2: reduce [(to-string first xs) ++ ys] 217 | m3: r 218 | (m1 ++ m2) ++ m3 219 | ] 220 | 221 | r0: (reduce [to-string first xs]) 222 | r1: foldr :g [] (non-empty-string-subsequences (rest xs)) 223 | 224 | r0 ++ r1 225 | ] 226 | 227 | permutations: function [ 228 | "returns the list of all permutations of the argument." 229 | xs [series!] 230 | ][ 231 | case [ 232 | (not series? xs) none 233 | (empty? xs) (reduce [xs]) 234 | (block? xs) (block-permutations xs) 235 | (string? xs) (string-permutations xs) 236 | ] 237 | ] 238 | 239 | block-permutations: function [ 240 | xs [series!] 241 | ][ 242 | either empty? xs [ 243 | copy [[]] ; Don't use [] 244 | ][ 245 | ys: block-permutations (rest xs) 246 | f: func [zs][block-between (first xs) zs] 247 | g: func [zs x][zs ++ x] 248 | foldl :g [] (map :f ys) 249 | ] 250 | ] 251 | 252 | block-between: function [ 253 | x 254 | ys [series!] 255 | ][ 256 | either (empty? ys) [reduce [reduce [x]]][block-between* x ys] 257 | ] 258 | 259 | block-between*: function [ 260 | x 261 | ys [series!] 262 | ][ 263 | m1: (reduce [(reduce [x]) ++ ys]) 264 | 265 | f: func [y][reduce [first ys] ++ y] 266 | zs: block-between x (rest ys) 267 | m2: map :f zs 268 | m1 ++ m2 269 | ] 270 | 271 | string-permutations: function [ 272 | xs [string!] 273 | ][ 274 | either empty? xs [ 275 | copy [""] ; Don't use [] 276 | ][ 277 | ys: string-permutations (rest xs) 278 | f: func [zs][string-between (first xs) zs] 279 | g: func [zs x][zs ++ x] 280 | foldl :g [] (map :f ys) 281 | ] 282 | ] 283 | 284 | string-between: function [ 285 | x [char!] 286 | ys [string!] 287 | ][ 288 | either (empty? ys) [reduce [to-string x]][string-between* x ys] 289 | ] 290 | 291 | string-between*: function [ 292 | x [char!] 293 | ys [string!] 294 | ][ 295 | m1: (reduce [(to-string x) ++ ys]) 296 | 297 | f: func [y][(to-string (first ys)) ++ y] 298 | zs: string-between x (rest ys) 299 | m2: map :f zs 300 | m1 ++ m2 301 | ] 302 | 303 | foldl: function [ 304 | "reduces the list using the binary operator, from left to right" 305 | f [any-function!] 306 | y 307 | xs [series!] 308 | ][ 309 | either empty? xs [ 310 | y 311 | ][ 312 | r: y 313 | foreach x xs [r: f r x] 314 | r 315 | ] 316 | ] 317 | 318 | "(a -> a -> a) -> [a] -> a" 319 | foldl1: function [ 320 | "A variant of foldl that has no base case, and thus may only be applied to non-empty structures." 321 | f [any-function!] 322 | xs [series!] 323 | ][ 324 | either empty? xs [none][foldl :f (first xs) (rest xs)] 325 | ] 326 | 327 | foldr: function [ 328 | "reduces the list using the binary operator, from right to left" 329 | g [any-function!] 330 | y 331 | xs [series!] 332 | ][ 333 | either empty? xs [ 334 | y 335 | ][ 336 | r: y 337 | foreach x (reverse xs) [r: g x r] 338 | r 339 | ] 340 | ] 341 | 342 | ;"(a -> a -> a) -> [a] -> a" 343 | foldr1: function [ 344 | "A variant of foldr that has no base case, and thus may only be applied to non-empty structures." 345 | f [any-function!] 346 | xs [series!] 347 | ][ 348 | either empty? xs [none][foldr :f (last xs) (most xs)] 349 | ] 350 | 351 | concat: function [ 352 | "The concatenation of all the elements of a container of lists." 353 | xs [series!] 354 | ][ 355 | case [ 356 | ([] == xs) (copy []) 357 | (all (map :string? xs)) (string-concat xs) 358 | (all (map :block? xs)) (block-concat xs) 359 | true none 360 | ] 361 | ] 362 | 363 | block-concat: function [ 364 | xs [series!] 365 | ][ 366 | f: func [y x][y ++ x] 367 | foldl :f [] xs 368 | ] 369 | 370 | string-concat: function [ 371 | xs 372 | ][ 373 | f: func [y x][y ++ x] 374 | foldl1 :f xs 375 | ] 376 | 377 | concatMap: function [ 378 | "Map a function over all the elements of a container and concatenate the resulting lists." 379 | f [any-function!] 380 | xs [series!] 381 | ][ 382 | either (string? xs) [ 383 | string-concatMap :f xs 384 | ][ 385 | block-concatMap :f xs 386 | ] 387 | ] 388 | 389 | string-concatMap: function [ 390 | f [any-function!] 391 | xs [string!] 392 | ][ 393 | ys: (map :f xs) 394 | either (string? ys) [ys][concat ys] 395 | ] 396 | 397 | block-concatMap: function [ 398 | f [any-function!] 399 | xs [series!] 400 | ][ 401 | concat (map :f xs) 402 | ] 403 | 404 | and': function [ 405 | "returns the conjunction of a container of Bools." 406 | xs' [series!] 407 | ][ 408 | xs: copy xs' 409 | either empty? xs [true][none <> (all xs)] 410 | ] 411 | 412 | or': function [ 413 | "returns the disjunction of a container of Bools." 414 | xs' [series!] 415 | ][ 416 | xs: copy xs' 417 | either empty? xs [false][none <> (any xs)] 418 | ] 419 | 420 | any': function [ 421 | "Determines whether any element of the structure satisfies the predicate." 422 | f [any-function!] 423 | xs' [series!] 424 | ][ 425 | xs: copy xs' 426 | r: false 427 | i: 1 428 | while [i <= (length? xs)][ 429 | if (f xs/:i) [ 430 | r: true 431 | break 432 | ] 433 | i: i + 1 434 | ] 435 | return r 436 | ] 437 | 438 | all': function [ 439 | "Determines whether any element of the structure satisfies the predicate." 440 | f [any-function!] 441 | xs' [series!] 442 | ][ 443 | xs: copy xs' 444 | r: true 445 | i: 1 446 | while [i <= (length? xs)][ 447 | if (true <> (f xs/:i)) [ 448 | r: false 449 | break 450 | ] 451 | i: i + 1 452 | ] 453 | return r 454 | ] 455 | 456 | sum: function [ 457 | "computes the sum of the numbers of a structure." 458 | xs [series!] 459 | ][ 460 | case [ 461 | [] == (xs) 0 462 | (all [block? xs (map :number? xs)]) (foldl1 func [y x][x + y] xs) 463 | true none] 464 | ] 465 | 466 | product: function [ 467 | "computes the product of the numbers of a structure." 468 | xs [series!] 469 | ][ 470 | case [ 471 | [] == (xs) 1 472 | (all [block? xs (map :number? xs)]) (foldl1 func [y x][x * y] xs) 473 | true none] 474 | ] 475 | 476 | maximum: function [ 477 | "The largest element of a non-empty structure." 478 | xs [series!] 479 | ][ 480 | case [ 481 | [] == (xs) none 482 | (all [(series? xs) (all (map :number? xs))]) (foldl1 func[y x][either y > x [y][x]] xs) 483 | true none] 484 | ] 485 | 486 | minimum: function [ 487 | "The largest element of a non-empty structure." 488 | xs [series!] 489 | ][ 490 | case [ 491 | [] == (xs) none 492 | (all [(series? xs) (all (map :number? xs))]) (foldl1 func[y x][either y < x [y][x]] xs) 493 | true none] 494 | ] 495 | 496 | scanl: function [ 497 | "scanl is similar to foldl, but returns a list of successive reduced values from the left" 498 | f [any-function!] 499 | y 500 | xs [series!] 501 | ][ 502 | either series? xs [scanl* :f y xs][none] 503 | ] 504 | 505 | scanl*: function [ 506 | "scanl is similar to foldl, but returns a list of successive reduced values from the left" 507 | f [any-function!] 508 | y 509 | xs [series!] 510 | ][ 511 | either empty? xs [reduce [y]][ 512 | ys: [y] 513 | r: y 514 | foreach x xs [ 515 | r: f r x 516 | ys: ys ++ (either (char? r) [to-string r][reduce [r]]) 517 | ] 518 | return ys 519 | ] 520 | ] 521 | 522 | scanl1: function [ 523 | "a variant of scanl that has no starting value argument" 524 | f [any-function!] 525 | xs [series!] 526 | ][ 527 | either (all [(series? xs) (0 < length? xs)]) [scanl* :f (first xs) (rest xs)][none] 528 | ] 529 | 530 | scanr: function [ 531 | "scanr is similar to foldr, but returns a list of successive reduced values from the left" 532 | f' [any-function!] 533 | y 534 | xs [series!] 535 | ][ 536 | f: func [x' y'][f' y' x'] 537 | reverse (scanl :f y (reverse xs)) 538 | ] 539 | 540 | scanr1: function [ 541 | "a variant of scanr that has no starting value argument" 542 | f' [any-function!] 543 | xs [series!] 544 | ][ 545 | f: func [y' x'][f' x' y'] 546 | either (all [(series? xs) (0 < (length? xs))]) [ 547 | reverse (scanl1 :f reverse xs) 548 | ][ 549 | none 550 | ] 551 | ] 552 | 553 | replicate: function [ 554 | "replicate n x is a list of length n with x the value of every element." 555 | n [integer!] 556 | x 557 | ][ 558 | xs: either (char? x) [""][copy []] 559 | ys: either (char? x) [to-string x][reduce [x]] 560 | i: 1 561 | while [i <= n][ 562 | xs: xs ++ ys 563 | i: i + 1 564 | ] 565 | xs 566 | ] 567 | 568 | take': func [ 569 | "applied to a list xs, returns the prefix of xs of length n, or xs itself if n > length? xs" 570 | n [integer!] 571 | xs [series!] 572 | ][ 573 | case [ 574 | (n > (length? xs)) xs 575 | (n <= 0) (either (string? xs) [""][[]]) 576 | (n <= (length? xs)) (take* n xs) 577 | ] 578 | ] 579 | 580 | take*: function [ 581 | n [integer!] 582 | xs [series!] 583 | ][ 584 | ys: either (string? xs) [""][copy []] 585 | i: 1 586 | while [ 587 | i <= n 588 | ][ 589 | ys: ys ++ (either (string? xs) [to-string (xs/:i)][reduce [xs/:i]]) 590 | i: i + 1] 591 | ys 592 | ] 593 | 594 | drop: function [ 595 | "returns the suffix of xs after the first n elements, or [] if n > length? xs" 596 | n [integer!] 597 | xs [series!] 598 | ][ 599 | case [ 600 | (n <= 0) xs 601 | (n >= (length? xs)) (either (string? xs) [""][[]]) 602 | true (drop* n xs) 603 | ] 604 | ] 605 | 606 | drop*: function [ 607 | n [integer!] 608 | xs [series!] 609 | ][ 610 | ys: either (string? xs) [""][copy []] 611 | i: n + 1 612 | while [ 613 | i <= (length? xs) 614 | ][ 615 | ys: ys ++ (either (string? xs) [to-string (xs/:i)][reduce [xs/:i]]) 616 | i: i + 1] 617 | ys 618 | ] 619 | 620 | splitAt: function [ 621 | "returns a tuple where first element is xs prefix of length n and second element is the remainder of the list" 622 | n [integer!] 623 | xs [series!] 624 | ][ 625 | reduce [(take' n xs) (drop n xs)] 626 | ] 627 | 628 | takeWhile: function [ 629 | " applied to a predicate p and a list xs, returns the longest prefix (possibly empty) of xs of elements that satisfy p" 630 | p [any-function!] 631 | xs [series!] 632 | ][ 633 | either (empty? xs) [xs][takeWhile* :p xs] 634 | ] 635 | 636 | takeWhile*: function [ 637 | p [any-function!] 638 | xs [series!] 639 | ][ 640 | ys: either (string? xs) [""][copy []] 641 | len: length? xs 642 | i: 1 643 | while [ 644 | all [(i <= len) (p (xs/:i))] 645 | ][ 646 | x: xs/:i 647 | ys: ys ++ (either (char? x) [to-string x][reduce [x]]) 648 | i: i + 1 649 | ] 650 | return ys 651 | ] 652 | 653 | dropWhile: function [ 654 | "returns the suffix remaining after takeWhile p xs" 655 | p [any-function!] 656 | xs [series!] 657 | ][ 658 | n: length? (takeWhile :p xs) 659 | drop n xs 660 | ] 661 | 662 | dropWhileEnd: function [ 663 | "returns the suffix remaining after takeWhile p xs" 664 | p [any-function!] 665 | xs [series!] 666 | ][ 667 | reverse' (dropWhile :p (reverse' xs)) 668 | ] 669 | 670 | span: function [ 671 | " applied to a predicate p and a list xs, returns a tuple where first element is longest prefix (possibly empty) of xs of elements that satisfy p and second element is the remainder of the list" 672 | p [any-function!] 673 | xs [series!] 674 | ][ 675 | reduce [(takeWhile :p xs) (dropWhile :p xs)] 676 | ] 677 | 678 | break': function [ 679 | "applied to a predicate p and a list xs, returns a tuple where first element is longest prefix (possibly empty) of xs of elements that do not satisfy p and second element is the remainder of the list" 680 | p [any-function!] 681 | xs [series!] 682 | ][ 683 | span func [x][not p x] xs 684 | ] 685 | 686 | stripPrefix: function [ 687 | "drops the given prefix from a list. It returns Nothing if the list did not start with the prefix given, or Just the list after the prefix, if it does." 688 | xs [series!] 689 | ys [series!] 690 | ][ 691 | either empty? xs [ys][stripPrefix* xs ys] 692 | ] 693 | 694 | stripPrefix*: function [ 695 | xs [series!] 696 | ys [series!] 697 | ][ 698 | n: length? xs 699 | either xs == (take' n ys) [drop n ys][none] 700 | ] 701 | 702 | group: function [ 703 | "takes a list and returns a list of lists such that the concatenation of the result is equal to the argument. Moreover, each sublist in the result contains only equal elements." 704 | xs [series!] 705 | ][ 706 | groupBy func [y x][y == x] xs 707 | ] 708 | 709 | inits: function [ 710 | "returns all initial segments of the argument, shortest first." 711 | xs [series!] 712 | ][ 713 | xss: either string? xs [[""]][[[]]] 714 | to-series: func [x][either (char? x) [to-string x][reduce [x]]] 715 | f: func [yss x][yss: yss ++ [(last yss) ++ (to-series x)]] 716 | foldl :f xss xs 717 | ] 718 | 719 | tails: function [ 720 | "returns all final segments of the argument, longest first." 721 | xs [series!] 722 | ][ 723 | reverse' (map :reverse' (inits (reverse xs))) 724 | ] 725 | 726 | isPrefixOf: function [ 727 | " takes two lists and returns True iff the first list is a prefix of the second." 728 | xs [series!] 729 | ys [series!] 730 | ][ 731 | n: length? xs 732 | xs == (take' n ys) 733 | ] 734 | 735 | isSuffixOf: function [ 736 | "takes two lists and returns True iff the first list is a suffix of the second." 737 | xs [series!] 738 | ys [series!] 739 | ][ 740 | n: length? xs 741 | (reverse' xs) == (take' n (reverse' ys)) 742 | ] 743 | 744 | isInfixOf: function [ 745 | "takes two lists and returns True iff the first list is contained, wholly and intact, anywhere within the second." 746 | xs [series!] 747 | ys [series!] 748 | ][ 749 | case [ 750 | (empty? xs) true 751 | (none == (find ys xs)) false 752 | true true 753 | ] 754 | ] 755 | 756 | isSubsequenceOf: function [ 757 | "takes two lists and returns True if all the elements of the first list occur, in order, in the second. The elements do not have to occur consecutively." 758 | xs [series!] 759 | ys [series!] 760 | ][ 761 | either (empty? xs) [true][isSubsequenceOf* xs ys] 762 | ] 763 | 764 | isSubsequenceOf*: function [ 765 | xs [series!] 766 | ys [series!] 767 | ][ 768 | either (empty? xs) [ 769 | return true 770 | ][ 771 | zs: find ys (first xs) 772 | either zs == none [false][isSubsequenceOf* (rest xs) zs] 773 | ] 774 | ] 775 | 776 | ;; Searching lists 777 | ;; Searching by equality 778 | elem: function [ 779 | "Does the element occur in the structure?" 780 | x 781 | xs [series!] 782 | ][ 783 | none <> (find xs x) 784 | ] 785 | 786 | notElem: function [ 787 | "notElem is the negation of elem." 788 | x 789 | xs [series!] 790 | ][ 791 | none == (find xs x) 792 | ] 793 | 794 | lookup: function [ 795 | "looks up a key in a association list (map)" 796 | key 797 | m [map!] 798 | ][ 799 | get 'm/:key 800 | ] 801 | 802 | ;;Searching with a predicate 803 | find': function [ 804 | "takes a predicate and a structure and returns the leftmost element of the structure matching the predicate, or Nothing if there is no such element." 805 | predicate-f [any-function!] 806 | xs [series!] 807 | ][ 808 | either empty? xs [none][find'* :predicate-f xs] 809 | ] 810 | 811 | find'*: function [ 812 | predicate-f [any-function!] 813 | xs' [series!] 814 | ][ 815 | xs: copy xs' 816 | found: false 817 | while [all [(not found) (not tail? xs)]][ 818 | x: first xs 819 | found: predicate-f x 820 | xs: next xs 821 | ] 822 | either found [x][none] 823 | ] 824 | 825 | filter: function [ 826 | "applying a predicate f to xs" 827 | f [any-function!] 828 | xs [series!] 829 | ][ 830 | yss: either string? xs [copy ""][copy []] 831 | g: func [ys x][either f x [append ys reduce [x]][ys]] 832 | zss: foldl :g yss xs 833 | ] 834 | 835 | partition: function [ 836 | "takes a predicate and a structure and returns the leftmost element of the structure matching the predicate, or Nothing if there is no such element." 837 | f [any-function!] 838 | xs [series!] 839 | ][ 840 | reduce [(filter :f xs) (filter func[x][not f x] xs)] 841 | ] 842 | 843 | ;;Indexing lists 844 | list-index*: function [ 845 | "List index (subscript) operator, starting from 0." 846 | xs [series!] 847 | i [integer!] 848 | ][ 849 | xs/(i + 1) 850 | ] 851 | !!: make op! :list-index* 852 | 853 | elemIndex: function [ 854 | "returns the index of the first element in the given list which is equal (by ==) to the query element, or Nothing if there is no such element." 855 | x 856 | xs [series!] 857 | ][ 858 | ys: find/case xs x 859 | either (ys == none) [none][offset? xs ys] 860 | ] 861 | 862 | elemIndices: function [ 863 | "returning the indices of all elements equal to the query element, in ascending order." 864 | x 865 | xs [series!] 866 | ][ 867 | ys: copy [] 868 | len: length? xs 869 | i: 1 870 | while [i <= len][ 871 | ys: either (x == xs/:i)[ys ++ (reduce [(i - 1)])][ys] 872 | i: i + 1 873 | ] 874 | return ys 875 | ] 876 | 877 | findIndex: function [ 878 | "takes a predicate and a list and returns the index of the first element in the list satisfying the predicate, or Nothing if there is no such element." 879 | f [any-function!] 880 | xs [series!] 881 | ][ 882 | len: length? xs 883 | i: 1 884 | r: none 885 | while [i <= len][ 886 | either (f xs/:i) == true [ 887 | (r: (i - 1)) 888 | break 889 | ][ 890 | i: i + 1 891 | ] 892 | ] 893 | return r 894 | ] 895 | 896 | findIndices: function [ 897 | "extends findIndex, by returning the indices of all elements satisfying the predicate, in ascending order." 898 | f [any-function!] 899 | xs [series!] 900 | ][ 901 | len: length? xs 902 | i: 1 903 | rs: [] 904 | while [i <= len][ 905 | rs: either (f xs/:i) == true [rs ++ (reduce [i - 1])][rs] 906 | i: i + 1 907 | ] 908 | return rs 909 | ] 910 | 911 | ;;Zipping and unzipping lists 912 | zip: function [ 913 | "takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded." 914 | xs [series!] 915 | ys [series!] 916 | ][ 917 | zss: copy [] 918 | len: min (length? xs) (length? ys) 919 | repeat i :len [ 920 | xy: reduce [xs/:i ys/:i] 921 | zss: zss ++ (reduce [xy]) 922 | ] 923 | return zss 924 | ] 925 | 926 | zip3: function [ 927 | "takes three lists and returns a list of triples, analogous to zip." 928 | xs [series!] 929 | ys [series!] 930 | zs [series!] 931 | ][ 932 | zss: copy [] 933 | len: minimum (reduce (map :length? reduce [xs ys zs])) 934 | repeat i :len [ 935 | xyz: reduce [xs/:i ys/:i zs/:i] 936 | zss: zss ++ (reduce [xyz]) 937 | ] 938 | return zss 939 | ] 940 | 941 | zip4: function [ 942 | "takes four lists and returns a list of quadruples, analogous to zip." 943 | xs [series!] 944 | ys [series!] 945 | zs [series!] 946 | us [series!] 947 | ][ 948 | zss: copy [] 949 | len: minimum (reduce (map :length? reduce [xs ys zs us])) 950 | repeat i :len [ 951 | xyzu: reduce [xs/:i ys/:i zs/:i us/:i] 952 | zss: zss ++ (reduce [xyzu]) 953 | ] 954 | return zss 955 | ] 956 | 957 | zip5: function [ 958 | "takes four lists and returns a list of five-tuples, analogous to zip." 959 | xs [series!] 960 | ys [series!] 961 | zs [series!] 962 | us [series!] 963 | vs [series!] 964 | ][ 965 | zss: copy [] 966 | len: minimum (reduce (map :length? reduce [xs ys zs us vs])) 967 | repeat i :len [ 968 | xyzuv: reduce [xs/:i ys/:i zs/:i us/:i vs/:i] 969 | zss: zss ++ (reduce [xyzuv]) 970 | ] 971 | return zss 972 | ] 973 | 974 | zip6: function [ 975 | "takes four lists and returns a list of six-tuples, analogous to zip." 976 | xs [series!] 977 | ys [series!] 978 | zs [series!] 979 | us [series!] 980 | vs [series!] 981 | ws [series!] 982 | ][ 983 | zss: copy [] 984 | len: minimum (reduce (map :length? reduce [xs ys zs us vs ws])) 985 | repeat i :len [ 986 | xyzuvw: reduce [xs/:i ys/:i zs/:i us/:i vs/:i ws/:i] 987 | zss: zss ++ (reduce [xyzuvw]) 988 | ] 989 | return zss 990 | ] 991 | 992 | zip7: function [ 993 | "takes four lists and returns a list of seven-tuples, analogous to zip." 994 | xs [series!] 995 | ys [series!] 996 | zs [series!] 997 | us [series!] 998 | vs [series!] 999 | ws [series!] 1000 | ts [series!] 1001 | ][ 1002 | zss: copy [] 1003 | len: minimum (reduce (map :length? reduce [xs ys zs us vs ws ts])) 1004 | repeat i :len [ 1005 | xyzuvwt: reduce [xs/:i ys/:i zs/:i us/:i vs/:i ws/:i ts/:i] 1006 | zss: zss ++ (reduce [xyzuvwt]) 1007 | ] 1008 | return zss 1009 | ] 1010 | 1011 | zipWith: function [ 1012 | "generalises zip by zipping with the function given as the first argument, instead of a tupling function." 1013 | f [any-function!] 1014 | xs [series!] 1015 | ys [series!] 1016 | ][ 1017 | rs: copy [] 1018 | len: minimum (reduce (map :length? reduce [xs ys])) 1019 | repeat i :len [ 1020 | r: f xs/:i ys/:i 1021 | rs: rs ++ (reduce [r]) 1022 | ] 1023 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1024 | ] 1025 | 1026 | zipWith3: function [ 1027 | "takes a function which combines three elements, as well as three lists and returns a list of their point-wise combination, analogous to zipWith." 1028 | f [any-function!] 1029 | xs [series!] 1030 | ys [series!] 1031 | zs [series!] 1032 | ][ 1033 | rs: copy [] 1034 | len: minimum (reduce (map :length? reduce [xs ys zs])) 1035 | repeat i :len [ 1036 | r: f xs/:i ys/:i zs/:i 1037 | rs: rs ++ (reduce [r]) 1038 | ] 1039 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1040 | ] 1041 | 1042 | zipWith4: function [ 1043 | "takes a function which combines three elements, as well as four lists and returns a list of their point-wise combination, analogous to zipWith." 1044 | f [any-function!] 1045 | xs [series!] 1046 | ys [series!] 1047 | zs [series!] 1048 | us [series!] 1049 | ][ 1050 | rs: copy [] 1051 | len: minimum (reduce (map :length? reduce [xs ys zs us])) 1052 | repeat i :len [ 1053 | r: f xs/:i ys/:i zs/:i us/:i 1054 | rs: rs ++ (reduce [r]) 1055 | ] 1056 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1057 | ] 1058 | 1059 | zipWith5: function [ 1060 | "takes a function which combines three elements, as well as five lists and returns a list of their point-wise combination, analogous to zipWith." 1061 | f [any-function!] 1062 | xs [series!] 1063 | ys [series!] 1064 | zs [series!] 1065 | us [series!] 1066 | vs [series!] 1067 | ][ 1068 | rs: copy [] 1069 | len: minimum (reduce (map :length? reduce [xs ys zs us vs])) 1070 | repeat i :len [ 1071 | r: f xs/:i ys/:i zs/:i us/:i vs/:i 1072 | rs: rs ++ (reduce [r]) 1073 | ] 1074 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1075 | ] 1076 | 1077 | zipWith6: function [ 1078 | "takes a function which combines three elements, as well as six lists and returns a list of their point-wise combination, analogous to zipWith." 1079 | f [any-function!] 1080 | xs [series!] 1081 | ys [series!] 1082 | zs [series!] 1083 | us [series!] 1084 | vs [series!] 1085 | ws [series!] 1086 | ][ 1087 | rs: copy [] 1088 | len: minimum (reduce (map :length? reduce [xs ys zs us vs ws])) 1089 | repeat i :len [ 1090 | r: f xs/:i ys/:i zs/:i us/:i vs/:i ws/:i 1091 | rs: rs ++ (reduce [r]) 1092 | ] 1093 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1094 | ] 1095 | 1096 | zipWith7: function [ 1097 | "takes a function which combines three elements, as well as seven lists and returns a list of their point-wise combination, analogous to zipWith." 1098 | f [any-function!] 1099 | xs [series!] 1100 | ys [series!] 1101 | zs [series!] 1102 | us [series!] 1103 | vs [series!] 1104 | ws [series!] 1105 | ts [series!] 1106 | ][ 1107 | rs: copy [] 1108 | len: minimum (reduce (map :length? reduce [xs ys zs us vs ws ts])) 1109 | repeat i :len [ 1110 | r: f xs/:i ys/:i zs/:i us/:i vs/:i ws/:i ts/:i 1111 | rs: rs ++ (reduce [r]) 1112 | ] 1113 | return either (all (map :char? rs)) [concat (map :to-string rs)][rs] 1114 | ] 1115 | 1116 | unzippable?: function [ 1117 | xss [series!] 1118 | ][ 1119 | either (empty? xss) [ 1120 | true 1121 | ][ 1122 | ts: map :type? xss 1123 | first 1124 | ] 1125 | ] 1126 | 1127 | normalize-series: func [xs][either (all (map :char? xs)) [concat (map :to-string xs)][xs]] 1128 | 1129 | unzip: function [ 1130 | "transforms a list of pairs into a list of first components and a list of second components." 1131 | xss [series!] 1132 | ][ 1133 | rs1: copy [] 1134 | rs2: copy [] 1135 | len: length? xss 1136 | repeat i :len [ 1137 | rs1: rs1 ++ (reduce [xss/:i/1]) 1138 | rs2: rs2 ++ (reduce [xss/:i/2]) 1139 | ] 1140 | return map :normalize-series (reduce [rs1 rs2]) 1141 | ] 1142 | 1143 | unzip3: function [ 1144 | "takes a list of triples and returns three lists, analogous to unzip." 1145 | xss [series!] 1146 | ][ 1147 | rs1: copy [] 1148 | rs2: copy [] 1149 | rs3: copy [] 1150 | len: length? xss 1151 | repeat i :len [ 1152 | rs1: rs1 ++ (reduce [xss/:i/1]) 1153 | rs2: rs2 ++ (reduce [xss/:i/2]) 1154 | rs3: rs3 ++ (reduce [xss/:i/3]) 1155 | ] 1156 | return map :normalize-series (reduce [rs1 rs2 rs3]) 1157 | ] 1158 | 1159 | unzip4: function [ 1160 | "takes a list of triples and returns four lists, analogous to unzip." 1161 | xss [series!] 1162 | ][ 1163 | rs1: copy [] 1164 | rs2: copy [] 1165 | rs3: copy [] 1166 | rs4: copy [] 1167 | len: length? xss 1168 | repeat i :len [ 1169 | rs1: rs1 ++ (reduce [xss/:i/1]) 1170 | rs2: rs2 ++ (reduce [xss/:i/2]) 1171 | rs3: rs3 ++ (reduce [xss/:i/3]) 1172 | rs4: rs4 ++ (reduce [xss/:i/4]) 1173 | ] 1174 | return map :normalize-series (reduce [rs1 rs2 rs3 rs4]) 1175 | ] 1176 | 1177 | unzip5: function [ 1178 | "takes a list of triples and returns five lists, analogous to unzip." 1179 | xss [series!] 1180 | ][ 1181 | rs1: copy [] 1182 | rs2: copy [] 1183 | rs3: copy [] 1184 | rs4: copy [] 1185 | rs5: copy [] 1186 | len: length? xss 1187 | repeat i :len [ 1188 | rs1: rs1 ++ (reduce [xss/:i/1]) 1189 | rs2: rs2 ++ (reduce [xss/:i/2]) 1190 | rs3: rs3 ++ (reduce [xss/:i/3]) 1191 | rs4: rs4 ++ (reduce [xss/:i/4]) 1192 | rs5: rs5 ++ (reduce [xss/:i/5]) 1193 | ] 1194 | return map :normalize-series (reduce [rs1 rs2 rs3 rs4 rs5]) 1195 | ] 1196 | 1197 | unzip6: function [ 1198 | "takes a list of triples and returns six lists, analogous to unzip." 1199 | xss [series!] 1200 | ][ 1201 | rs1: copy [] 1202 | rs2: copy [] 1203 | rs3: copy [] 1204 | rs4: copy [] 1205 | rs5: copy [] 1206 | rs6: copy [] 1207 | len: length? xss 1208 | repeat i :len [ 1209 | rs1: rs1 ++ (reduce [xss/:i/1]) 1210 | rs2: rs2 ++ (reduce [xss/:i/2]) 1211 | rs3: rs3 ++ (reduce [xss/:i/3]) 1212 | rs4: rs4 ++ (reduce [xss/:i/4]) 1213 | rs5: rs5 ++ (reduce [xss/:i/5]) 1214 | rs6: rs6 ++ (reduce [xss/:i/6]) 1215 | ] 1216 | return map :normalize-series (reduce [rs1 rs2 rs3 rs4 rs5 rs6]) 1217 | ] 1218 | 1219 | unzip7: function [ 1220 | "takes a list of triples and returns seven lists, analogous to unzip." 1221 | xss [series!] 1222 | ][ 1223 | rs1: copy [] 1224 | rs2: copy [] 1225 | rs3: copy [] 1226 | rs4: copy [] 1227 | rs5: copy [] 1228 | rs6: copy [] 1229 | rs7: copy [] 1230 | len: length? xss 1231 | repeat i :len [ 1232 | rs1: rs1 ++ (reduce [xss/:i/1]) 1233 | rs2: rs2 ++ (reduce [xss/:i/2]) 1234 | rs3: rs3 ++ (reduce [xss/:i/3]) 1235 | rs4: rs4 ++ (reduce [xss/:i/4]) 1236 | rs5: rs5 ++ (reduce [xss/:i/5]) 1237 | rs6: rs6 ++ (reduce [xss/:i/6]) 1238 | rs7: rs7 ++ (reduce [xss/:i/7]) 1239 | ] 1240 | return map :normalize-series (reduce [rs1 rs2 rs3 rs4 rs5 rs6 rs7]) 1241 | ] 1242 | 1243 | ;;Special lists 1244 | ;;Functions on strings 1245 | lines: function [ 1246 | xs [string!] 1247 | ][ 1248 | "breaks a string up into a list of strings at newline characters. The resulting strings do not contain newlines." 1249 | split xs "^(line)" 1250 | ] 1251 | 1252 | words: function [ 1253 | "breaks a string up into a list of words, which were delimited by white space." 1254 | xs [string!] 1255 | ][ 1256 | split (trim/lines xs) " " 1257 | ] 1258 | 1259 | unlines: function [ 1260 | "an inverse operation to lines. It joins lines, after appending a terminating newline to each." 1261 | xss [series!] 1262 | ][ 1263 | either none == (all (map :string? xss)) [ 1264 | none 1265 | ][ 1266 | concatMap func [xs][xs ++ "^(line)"] xss 1267 | ] 1268 | ] 1269 | 1270 | unwords: function [ 1271 | "an inverse operation to words. It joins words with separating spaces." 1272 | xss [series!] 1273 | ][ 1274 | either none == (all (map :string? xss)) [ 1275 | none 1276 | ][ 1277 | concat intersperse " " xss 1278 | ] 1279 | ] 1280 | 1281 | ;;"Set" operations 1282 | nub: function [ 1283 | "removes duplicate elements from a list. In particular, it keeps only the first occurrence of each element. (The name nub means `essence'.) It is a special case of nubBy, which allows the programmer to supply their own equality test." 1284 | xs [series!] 1285 | ][ 1286 | unique/case xs 1287 | ] 1288 | 1289 | delete': function [ 1290 | " removes the first occurrence of x from its list argument." 1291 | x 1292 | xs' [series!] 1293 | ][ 1294 | xs: copy xs' 1295 | rs: find/case xs x 1296 | either rs == none [xs][head remove rs] 1297 | ] 1298 | 1299 | union': function [ 1300 | "returns the list union of the two lists." 1301 | xs' [series!] 1302 | ys' [series!] 1303 | ][ 1304 | illegal-parameters?: function [us vs][all [string? us series? vs (not string? vs)]] 1305 | either any [(illegal-parameters? xs' ys') (illegal-parameters? ys' xs')][ 1306 | none 1307 | ][ 1308 | union'* xs' ys' 1309 | ] 1310 | ] 1311 | 1312 | union'*: function [ 1313 | xs' [series!] 1314 | ys' [series!] 1315 | ][ 1316 | xs: copy xs' 1317 | ys: copy ys' 1318 | f: func [rs y] [either elem y xs [rs][rs ++ reduce [y]]] 1319 | foldl :f xs ys 1320 | ] 1321 | 1322 | intersect': function [ 1323 | "takes the list intersection of two lists." 1324 | xs' [series!] 1325 | ys' [series!] 1326 | ][ 1327 | illegal-parameters?: function [us vs][all [string? us series? vs (not string? vs)]] 1328 | either any [(illegal-parameters? xs' ys') (illegal-parameters? ys' xs')][ 1329 | none 1330 | ][ 1331 | intersect'* xs' ys' 1332 | ] 1333 | ] 1334 | 1335 | intersect'*: function [ 1336 | xs' [series!] 1337 | ys' [series!] 1338 | ][ 1339 | either ((length? xs') > (length? ys')) [ 1340 | xs: copy xs' 1341 | ys: copy ys' 1342 | ][ 1343 | xs: copy ys' 1344 | ys: copy xs' 1345 | ] 1346 | f: func [rs y] [either elem y xs [rs ++ reduce [y]][rs]] 1347 | rs: copy either all [string? xs string? ys][""][[]] 1348 | foldl :f rs ys 1349 | ] 1350 | 1351 | ;;Ordered lists 1352 | sort': function [ 1353 | "It is a special case of sortBy, which allows the programmer to supply their own comparison function. Elements are arranged from from lowest to highest, keeping duplicates in the order they appeared in the input." 1354 | xs [series!] 1355 | ][ 1356 | sortBy func [x y][x < y] xs 1357 | ] 1358 | 1359 | sortOn: function [ 1360 | "Sort a list by comparing the results of a key function applied to each element." 1361 | f [any-function!] 1362 | xs [series!] 1363 | ][ 1364 | sortBy func [x y][(f x) < (f y)] xs 1365 | ] 1366 | 1367 | insert': function [ 1368 | "takes an element and a list and inserts the element into the list at the first position where it is less than or equal to the next element." 1369 | x' 1370 | xs' [series!] 1371 | ][ 1372 | x: either scalar? x' [x'][copy x'] 1373 | xs: copy xs' 1374 | insert xs x 1375 | return xs 1376 | ] 1377 | 1378 | ;;Generalized functions 1379 | ;;User-supplied equality 1380 | nubBy: function [ 1381 | "behaves just like nub, except it uses a user-supplied equality predicate instead of the overloaded == function" 1382 | f [any-function!] 1383 | xs [series!] 1384 | ][ 1385 | add-element: function [ 1386 | ys x 1387 | ][ 1388 | either (find' function [y][do [f x y]] ys) [ 1389 | ys 1390 | ][ 1391 | zs: reduce either (char? x) [to-string x][reduce [x]] 1392 | ys ++ zs 1393 | ] 1394 | ] 1395 | rs: either string? xs [""][[]] 1396 | foldl :add-element rs xs 1397 | ] 1398 | 1399 | deleteBy: function [ 1400 | "behaves like delete, but takes a user-supplied equality predicate." 1401 | f [any-function!] 1402 | x 1403 | xs' [series!] 1404 | ][ 1405 | xs: copy xs' 1406 | i: elemIndex x xs 1407 | case [ 1408 | (i == none) (copy xs) 1409 | (i == 0) (rest xs) 1410 | true ((take' i xs) ++ (drop (i + 1) xs)) 1411 | ] 1412 | ] 1413 | 1414 | deleteFirstsBy: function [ 1415 | "takes a predicate and two lists and returns the first list with the first occurrence of each element of the second list removed." 1416 | f [any-function!] 1417 | xs' [series!] 1418 | ys' [series!] 1419 | ][ 1420 | xs: copy xs' 1421 | ys: copy ys' 1422 | deleteFirst: func [zs x][deleteBy :f x zs] 1423 | foldl :deleteFirst xs ys 1424 | ] 1425 | 1426 | unionBy: function [ 1427 | "the non-overloaded version of union." 1428 | f [any-function!] 1429 | xs [series!] 1430 | ys [series!] 1431 | ][ 1432 | zs: deleteFirstsBy :f (nub ys) xs 1433 | xs ++ zs 1434 | ] 1435 | 1436 | intersectBy: function [ 1437 | "the non-overloaded version of intersect'." 1438 | f [any-function!] 1439 | xs [series!] 1440 | ys [series!] 1441 | ][ 1442 | intersected?: func [x][any' func [y][f x y] ys] 1443 | filter :intersected? xs 1444 | ] 1445 | 1446 | groupBy: function [ 1447 | "the non-overloaded version of group." 1448 | f [any-function!] 1449 | xs [series!] 1450 | ][ 1451 | case [ 1452 | (empty? xs) (copy []) 1453 | (1 == (length? xs)) (reduce [xs]) 1454 | true (groupBy* :f xs) 1455 | ] 1456 | ] 1457 | 1458 | groupBy*: function [ 1459 | f [any-function!] 1460 | xs' [series!] 1461 | ][ 1462 | zss: copy [] 1463 | xs: copy xs' 1464 | while [0 < (length? xs)][ 1465 | y: first xs 1466 | ys: takeWhile (func [x][f y x]) (rest xs) 1467 | xs: drop (length? ys) (rest xs) 1468 | zs: either (char? y) [to-string y][reduce [y]] 1469 | yss: reduce [zs ++ ys] 1470 | zss: either (empty? ys) [zss ++ (reduce [zs])][zss ++ yss] 1471 | ] 1472 | return zss 1473 | ] 1474 | 1475 | ;;User-supplied comparison 1476 | sortBy: function [ 1477 | "the non-overloaded version of sort." 1478 | f [any-function!] 1479 | xs [series!] 1480 | ][ 1481 | either string? xs [ 1482 | string-sortBy :f xs 1483 | ][ 1484 | sort/compare (copy xs) :f 1485 | ] 1486 | ] 1487 | 1488 | string-sortBy: function [ 1489 | f [any-function!] 1490 | xs [series!] 1491 | ][ 1492 | g: func [x y][f (to-char x) (to-char y)] 1493 | ys: map :to-string xs 1494 | concat sort/compare ys :g 1495 | ] 1496 | 1497 | insertBy: function [ 1498 | "the non-overloaded version of insert'." 1499 | f [any-function!] 1500 | x 1501 | xs [series!] 1502 | ][ 1503 | i: indexElemBy* :f x xs 1504 | ys: either char? x [to-string x][reduce [x]] 1505 | either i == none [xs ++ ys][(take' i xs) ++ ys ++ (drop i xs)] 1506 | ] 1507 | 1508 | indexElemBy*: function [ 1509 | f [any-function!] 1510 | x 1511 | xs [series!] 1512 | ][ 1513 | i: 1 1514 | len: length? xs 1515 | while [i <= len][ 1516 | either f x xs/:i [return (i - 1)][i: i + 1] 1517 | ] 1518 | return none 1519 | ] 1520 | 1521 | 1522 | maximumBy: function [ 1523 | "the non-overloaded version of maximum." 1524 | f [any-function!] 1525 | xs [series!] 1526 | ][ 1527 | case [ 1528 | (empty? xs) none 1529 | (and' (map :number? xs)) (maximumBy* :f xs) 1530 | (1 == (length nub (map :type? xs))) (maximumBy* :f xs) 1531 | true none 1532 | ] 1533 | ] 1534 | 1535 | maximumBy*: function [ 1536 | f [any-function!] 1537 | xs [series!] 1538 | ][ 1539 | r: first xs 1540 | foldl func [r x][either f r x == true [r][x]] r (rest xs) 1541 | ] 1542 | 1543 | minimumBy: function [ 1544 | "the non-overloaded version of minimum." 1545 | f [any-function!] 1546 | xs [series!] 1547 | ][ 1548 | case [ 1549 | (empty? xs) none 1550 | (and' (map :number? xs)) (minimumBy* :f xs) 1551 | (1 == (length nub (map :type? xs))) (minimumBy* :f xs) 1552 | true none 1553 | ] 1554 | ] 1555 | 1556 | minimumBy*: function [ 1557 | f [any-function!] 1558 | xs [series!] 1559 | ][ 1560 | r: first xs 1561 | foldl func [r x][either true == (f r x) [r][x]] r (rest xs) 1562 | ] 1563 | 1564 | left-to-right-compositions: function [x fs][ 1565 | accum: function [y f][ 1566 | g: get-function* f 1567 | r: reduce [g y] 1568 | either ((type? first r) == unset!) [break][first r] 1569 | ] 1570 | foldl :accum x fs 1571 | ] 1572 | 1573 | get-function*: function [f][ 1574 | case [ 1575 | (word? f) (get f) 1576 | (path? f) (function [x] reduce [f 'x]) 1577 | true (do f) 1578 | ] 1579 | ] 1580 | 1581 | ;;"Sequentially compose functions, passing any value produced by the first as an argument to the second." 1582 | >>>=: make op! :left-to-right-compositions 1583 | 1584 | swap': function [ 1585 | "Swap the components of a pair" 1586 | xs [series! pair!] 1587 | ][ 1588 | case [ 1589 | (pair? xs) (swap* xs) 1590 | (and' reduce [(series? xs) (2 == length? xs)]) (swap* xs) 1591 | true (cause-error 'script 'invalid-arg [xs])] 1592 | ] 1593 | 1594 | swap*: func [ 1595 | xs [series! pair!] 1596 | ][ 1597 | a: first xs 1598 | b: second xs 1599 | case [ 1600 | pair? xs (make pair! copy reduce [b a]) 1601 | string? xs (copy rejoin reduce [b a]) 1602 | series? xs (copy reduce [b a]) 1603 | ] 1604 | ] 1605 | -------------------------------------------------------------------------------- /data-maybe-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Maybe test script" 3 | Author: "unchartedworks" 4 | File: %data-maybe-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %data-list.red 13 | #include %data-function.red 14 | #include %prelude.red 15 | #include %data-maybe.red 16 | 17 | ~~~start-file~~~ "data-maybe" 18 | 19 | ===start-group=== "Just" 20 | --test-- "integer! -> Just integer!" 21 | y: Just 1 22 | z: Just 1 23 | --assert* [y == z] 24 | 25 | --test-- "string! -> Just string!" 26 | y: Just "red" 27 | z: Just "red" 28 | --assert* [y == z] 29 | ===end-group=== 30 | 31 | ===start-group=== "Nothing" 32 | --test-- "Nothing 1" 33 | y: Nothing 34 | z: Nothing 35 | --assert* [y == z] 36 | 37 | --test-- "Nothing 2" 38 | y: Nothing 39 | z: none 40 | --assert* [y <> z] 41 | ===end-group=== 42 | 43 | ===start-group=== "maybe" 44 | --test-- "integer! -> (integer! -> integer!) -> Maybe integer! -> integer! 1" 45 | y: 4 46 | z: maybe 0 ([x] -> [x + 3]) Just 1 47 | --assert* [y == z] 48 | 49 | --test-- "integer! -> (integer! -> integer!) -> Maybe integer! -> integer! 2" 50 | y: 0 51 | z: maybe 0 ([x] -> [x + 3]) Nothing 52 | --assert* [y == z] 53 | 54 | --test-- "string! -> (integer! -> string!) -> Maybe integer! -> string! 1" 55 | y: "A" 56 | z: maybe "B" ([x] -> [to-string to-char (x + to-integer #"A")]) Just 0 57 | --assert* [y == z] 58 | 59 | --test-- "string! -> (integer! -> string!) -> Maybe integer! -> string! 1" 60 | y: "B" 61 | z: maybe "B" ([x] -> [to-string to-char (x + to-integer #"A")]) Nothing 62 | --assert* [y == z] 63 | ===end-group=== 64 | 65 | ===start-group=== "isJust" 66 | --test-- "Just integer! -> logic!" 67 | y: true 68 | z: isJust Just 3 69 | --assert* [y == z] 70 | 71 | --test-- "Just string! -> logic!" 72 | y: true 73 | z: isJust Just "red" 74 | --assert* [y == z] 75 | 76 | --test-- "Nothing -> logic!" 77 | y: false 78 | z: isJust Nothing 79 | --assert* [y == z] 80 | 81 | --test-- "Just Nothing -> logic!" 82 | y: true 83 | z: isJust Just Nothing 84 | --assert* [y == z] 85 | ===end-group=== 86 | 87 | ===start-group=== "isNothing" 88 | --test-- "Just integer! -> logic!" 89 | y: false 90 | z: isNothing Just 3 91 | --assert* [y == z] 92 | 93 | --test-- "Just string! -> logic!" 94 | y: false 95 | z: isNothing Just "red" 96 | --assert* [y == z] 97 | 98 | --test-- "Nothing -> logic!" 99 | y: true 100 | z: isNothing Nothing 101 | --assert* [y == z] 102 | 103 | --test-- "Just Nothing -> logic!" 104 | y: false 105 | z: isNothing Just Nothing 106 | --assert* [y == z] 107 | 108 | ===end-group=== 109 | 110 | ===start-group=== "fromJust" 111 | --test-- "Just integer! -> integer!" 112 | y: 3 113 | z: fromJust Just 3 114 | --assert* [y == z] 115 | 116 | --test-- "Just string! -> integer!" 117 | y: "red" 118 | z: fromJust Just "red" 119 | --assert* [y == z] 120 | 121 | --test-- "Just Nothing -> logic!" 122 | y: Nothing 123 | z: fromJust Just Nothing 124 | --assert* [y == z] 125 | ===end-group=== 126 | 127 | ===start-group=== "fromMaybe" 128 | --test-- "integer! -> Maybe integer! -> integer! 1" 129 | y: 3 130 | z: fromMaybe 0 Just 3 131 | --assert* [y == z] 132 | 133 | --test-- "integer! -> Maybe integer! -> integer! 2" 134 | y: 0 135 | z: fromMaybe 0 Nothing 136 | --assert* [y == z] 137 | 138 | --test-- "Maybe string! -> string! 1" 139 | y: "red" 140 | z: fromMaybe "blue" Just "red" 141 | --assert* [y == z] 142 | 143 | --test-- "Maybe string! -> string! 2" 144 | y: "blue" 145 | z: fromMaybe "blue" Nothing 146 | --assert* [y == z] 147 | 148 | --test-- "Nothing -> logic!" 149 | y: true 150 | z: fromMaybe true Nothing 151 | --assert* [y == z] 152 | 153 | ===end-group=== 154 | 155 | ===start-group=== "listToMaybe" 156 | --test-- "[integer!] -> Maybe integer! 1" 157 | y: Just 1 158 | z: listToMaybe [1 2 3] 159 | --assert* [y == z] 160 | 161 | --test-- "[integer!] -> Maybe integer! 2" 162 | y: Nothing 163 | z: listToMaybe [] 164 | --assert* [y == z] 165 | 166 | --test-- "[string!] -> Maybe string! 1" 167 | y: Just "abc" 168 | z: listToMaybe ["abc" "def"] 169 | --assert* [y == z] 170 | 171 | --test-- "[string!] -> Maybe string! 2" 172 | y: Nothing 173 | z: listToMaybe [] 174 | --assert* [y == z] 175 | 176 | --test-- "string! -> Maybe char! 1" 177 | y: Just #"a" 178 | z: listToMaybe "abc" 179 | --assert* [y == z] 180 | 181 | --test-- "string! -> Maybe char! 2" 182 | y: Nothing 183 | z: listToMaybe "" 184 | --assert* [y == z] 185 | ===end-group=== 186 | 187 | ===start-group=== "catMaybes" 188 | --test-- "[Maybe integer!] -> [integer!] 1" 189 | ys: [2 3] 190 | zs: catMaybes [Nothing Just 2 Just 3] 191 | --assert* [y == z] 192 | 193 | --test-- "[Maybe integer!] -> [integer!] 2" 194 | ys: [] 195 | zs: catMaybes [Nothing Nothing Nothing] 196 | --assert* [y == z] 197 | 198 | --test-- "[Maybe integer!] -> [integer!] 3" 199 | ys: [] 200 | zs: catMaybes [] 201 | --assert* [y == z] 202 | 203 | --test-- "[Maybe string!] -> [string!] 1" 204 | ys: ["hello" "world"] 205 | zs: catMaybes [Just "hello" Nothing Just "world"] 206 | --assert* [y == z] 207 | 208 | --test-- "[Maybe string!] -> [string!] 2" 209 | ys: ["world"] 210 | zs: catMaybes [Nothing Just "world"] 211 | --assert* [y == z] 212 | 213 | --test-- "[Maybe char!] -> string! 1" 214 | ys: "abc" 215 | zs: catMaybes [Nothing Just #"a" Just #"b" Nothing Just #"c"] 216 | --assert* [y == z] 217 | 218 | --test-- "[Maybe char!] -> string! 2" 219 | ys: "a" 220 | zs: catMaybes [Nothing Nothing Just #"a"] 221 | --assert* [y == z] 222 | ===end-group=== 223 | 224 | ===start-group=== "mapMaybes" 225 | --test-- "[Maybe integer!] -> [integer!] 1" 226 | f: [x] -> [either x > 2 [Just x][Nothing]] 227 | xs: [1 2 3] 228 | ys: [1 2] 229 | zs: mapMaybes :f xs 230 | --assert* [y == z] 231 | 232 | --test-- "[Maybe integer!] -> [integer!] 2" 233 | f: [x] -> [either x > 2 [Just x][Nothing]] 234 | xs: [] 235 | ys: [1 2] 236 | zs: mapMaybes :f xs 237 | --assert* [y == z] 238 | 239 | --test-- "[Maybe string!] -> [integer!] 1" 240 | f: [x] -> [either (length? x) > 2 [Just length? x][Nothing]] 241 | xs: ["a" "ab" "abc"] 242 | ys: [3] 243 | zs: mapMaybes :f xs 244 | --assert* [y == z] 245 | 246 | --test-- "[Maybe string!] -> [integer!] 2" 247 | f: [x] -> [either (length? x) > 2 [Just length? x][Nothing]] 248 | xs: ["a" "ab"] 249 | ys: [3] 250 | zs: mapMaybes :f xs 251 | --assert* [y == z] 252 | 253 | --test-- "[Maybe string!] -> string" 254 | f: [x] -> [either ((:not . :empty?) x) [Just last x][Nothing]] 255 | xs: ["a" "ab" "abc"] 256 | ys: "abc" 257 | zs: mapMaybes :f xs 258 | --assert* [y == z] 259 | ===end-group=== 260 | 261 | ~~~end-file~~~ -------------------------------------------------------------------------------- /data-maybe.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Data.Maybe" 3 | Author: "unchartedworks" 4 | File: %data-maybe.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | Nothing: [] -> [make object! [type: 'Nothing]] 11 | Just: [x] -> [make object! [type: 'Just value: x]] 12 | 13 | maybe: [ 14 | " takes a default value, a function, and a Maybe value. If the Maybe value is Nothing, the function returns the default value. Otherwise, it applies the function to the value inside the Just and returns the result." 15 | y 16 | f 17 | mx [object!] 18 | ] -> [ 19 | case [ 20 | (isNothing mx) y 21 | (isJust mx) (f fromJust mx) 22 | ] 23 | ] 24 | 25 | isJust: [ 26 | "returns True iff its argument is of the form Just _" 27 | x [object!] 28 | ] -> [x/type == 'Just] 29 | 30 | isNothing: [ 31 | "returns True iff its argument is Nothing." 32 | x [object!] 33 | ] -> [x/type == 'Nothing] 34 | 35 | fromJust: [ 36 | "extracts the element out of a Just and throws an error if its argument is Nothing." 37 | x [object!] 38 | ] -> [x/value] 39 | 40 | fromMaybe: [ 41 | "takes a default value and and Maybe value. If the Maybe is Nothing, it returns the default values; otherwise, it returns the value contained in the Maybe." 42 | y 43 | mx [object!] 44 | ] -> [ 45 | case [ 46 | (isNothing mx) y 47 | (isJust mx) (fromJust mx) 48 | ] 49 | ] 50 | 51 | listToMaybe: [ 52 | "The listToMaybe function returns Nothing on an empty list or Just a where a is the first element of the list." 53 | xs [series!] 54 | ] -> [ 55 | either empty? xs [Nothing][Just first xs] 56 | ] 57 | 58 | catMaybes: [ 59 | "The maybeToList function returns an empty list when given Nothing or a singleton list when not given Nothing." 60 | mxs [series!] 61 | ] -> [ 62 | xs: map :fromJust (filter :isJust reduce mxs) 63 | either (all' :char? xs) [copy rejoin xs][xs] 64 | ] 65 | 66 | mapMaybes: [ 67 | "The mapMaybe function is a version of map which can throw out elements. In particular, the functional argument returns something of type Maybe b. If this is Nothing, no element is added on to the result list. If it is Just b, then b is included in the result list." 68 | f [function!] 69 | xs [series!] 70 | ] -> [ 71 | catMaybes map :f xs 72 | ] 73 | -------------------------------------------------------------------------------- /haskell.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "HaskellRed" 3 | Author: "unchartedworks" 4 | File: %haskell.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %data-function.red 11 | #include %data-list.red 12 | #include %prelude.red 13 | #include %data-maybe.red 14 | #include %data-either.red 15 | #include %control-monad.red 16 | #include %data-char.red 17 | -------------------------------------------------------------------------------- /playground.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "playground" 3 | Author: "unchartedworks" 4 | File: %all-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %haskell.red 11 | 12 | ;data-list 13 | print "DataList" 14 | ;map 15 | print "map" 16 | xs: [1 2 3] 17 | ys: (map :to-string xs) 18 | print ys 19 | 20 | ;filter 21 | print "filter" 22 | xs: [1 "2" 3 "4" 5 "6"] 23 | ys: filter :integer? xs 24 | print ys 25 | 26 | ;foldl 27 | print "foldl" 28 | xs: [1 2 3 4] 29 | f: func [y x][x * y] 30 | ys: foldl :f 1 xs 31 | print ys 32 | print "" 33 | 34 | ;data-char 35 | print "DataChar" 36 | print isControl #"t" 37 | print "" 38 | 39 | ;data-function 40 | print "DataFunction" 41 | f1: func [x][x * 2] 42 | f2: func [x][length? x] 43 | f: :f1 . :f2 44 | print f "abc" 45 | print "" 46 | 47 | ;prelude 48 | print "Prelude" 49 | f: [x] -> [x + 1] 50 | print f 1 51 | print "" 52 | 53 | ;maybe 54 | print "Maybe" 55 | hit: [x] -> [Just (x + 8)] 56 | stand: [x] -> [either x > 21 [Nothing][Just x]] 57 | win: [x] -> [Just "$1000"] 58 | showtime: [x] -> [Just ("You win " ++ x ++ "!")] 59 | 60 | blackjack: [x [object!]] -> [x >>= :hit >>= :hit >>= :stand >>= :win >>= :showtime] 61 | print blackjack Just 3 62 | print "" 63 | 64 | ;either 65 | print "Either" 66 | print fromRight Right 3 67 | print "" 68 | 69 | ;control-monad 70 | print "Control-Monad" 71 | isTestFile: [x] -> [(isSuffixOf "-test.red" (to-string x)) && (%all-test.red <> x) && (not (isPrefixOf ".#" (to-string x)))] 72 | filterTestFiles: [xs] -> [filter :isTestFile xs] 73 | 74 | xs: %./ >>>= [read filterTestFiles] 75 | print xs -------------------------------------------------------------------------------- /playground.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | red --cli ./playground.red 3 | -------------------------------------------------------------------------------- /prelude-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Prelude test script" 3 | Author: "unchartedworks" 4 | File: %prelude-test.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | #include %quick-test/quick-test.red 11 | 12 | #include %data-function.red 13 | #include %data-list.red 14 | #include %prelude.red 15 | 16 | ~~~start-file~~~ "prelude" 17 | 18 | ===start-group=== "&&" 19 | --test-- "logic! -> logic! -> logic! 1" 20 | y: false 21 | z: false && false 22 | --assert* [y == z] 23 | 24 | --test-- "logic! -> logic! -> logic! 2" 25 | y: false 26 | z: false && true 27 | --assert* [y == z] 28 | 29 | --test-- "logic! -> logic! -> logic! 3" 30 | y: false 31 | z: true && false 32 | --assert* [y == z] 33 | 34 | --test-- "logic! -> logic! -> logic! 4" 35 | y: true 36 | z: true && true 37 | --assert* [y == z] 38 | ===end-group=== 39 | 40 | ===start-group=== "||" 41 | --test-- "logic! -> logic! -> logic! 1" 42 | y: false 43 | z: false || false 44 | --assert* [y == z] 45 | 46 | --test-- "logic! -> logic! -> logic! 2" 47 | y: true 48 | z: false || true 49 | --assert* [y == z] 50 | 51 | --test-- "logic! -> logic! -> logic! 3" 52 | y: true 53 | z: true || false 54 | --assert* [y == z] 55 | 56 | --test-- "logic! -> logic! -> logic! 4" 57 | y: true 58 | z: true || true 59 | --assert* [y == z] 60 | ===end-group=== 61 | 62 | ===start-group=== "not'" 63 | --test-- "logic! -> logic! 1" 64 | y: true 65 | z: not' false 66 | --assert* [y == z] 67 | 68 | --test-- "logic! -> logic! 2" 69 | y: false 70 | z: not' true 71 | --assert* [y == z] 72 | ===end-group=== 73 | 74 | ===start-group=== "otherwise" 75 | --test-- "logic! -> logic! 1" 76 | x: -1 77 | y: -1 78 | z: case [x > 0 1 otherwise -1] 79 | --assert* [y == z] 80 | 81 | --test-- "logic! -> logic! 2" 82 | x: 2 83 | y: 1 84 | z: case [x > 0 1 otherwise -1 (x == 0) 0] 85 | --assert* [y == z] 86 | ===end-group=== 87 | 88 | ===start-group=== "fst" 89 | --test-- "pair! -> integer!" 90 | y: 3 91 | z: fst 3x5 92 | --assert* [y == z] 93 | 94 | --test-- "[integer!] -> integer! 1" 95 | y: 1 96 | z: fst [1 5] 97 | --assert* [y == z] 98 | 99 | --test-- "[integer!] -> integer!" 100 | y: none 101 | z: attempt [fst []] 102 | --assert* [y == z] 103 | ===end-group=== 104 | 105 | ===start-group=== "snd" 106 | --test-- "pair! -> integer!" 107 | y: 5 108 | z: snd 3x5 109 | --assert* [y == z] 110 | 111 | --test-- "[integer!] -> integer! 1" 112 | y: 5 113 | z: snd [1 5] 114 | --assert* [y == z] 115 | 116 | --test-- "[integer!] -> integer!" 117 | y: none 118 | z: attempt [snd []] 119 | --assert* [y == z] 120 | ===end-group=== 121 | 122 | ; ===start-group=== "curry" 123 | ; --test-- "(integer! -> integer! -> integer!) -> integer! -> (integer! -> integer!) 1" 124 | ; f: curry [x y] -> [x + y] 2 125 | ; y: 6 126 | ; z: f 4 127 | ; --assert* [y == z] 128 | 129 | ; --test-- "(integer! -> integer! -> integer!) -> integer! -> (integer! -> integer!) 2" 130 | ; f: curry [x y] -> [x * y] 2 131 | ; y: 8 132 | ; z: f 4 133 | ; --assert* [y == z] 134 | 135 | ; --test-- "(integer! -> integer! -> integer!) -> integer! -> (integer! -> integer!) 3" 136 | ; f: curry [x y] -> [x * y] 2 137 | ; y: 8 138 | ; z: 4 & curry :add 4 139 | ; --assert* [y == z] 140 | 141 | ; --test-- "(integer! -> integer! -> integer!) -> integer! -> (integer! -> integer!) 4" 142 | ; f: curry [x y z] -> [x + y + z] 1 143 | ; y: none 144 | ; z: attempt [f 2] 145 | ; --assert* [y == z] 146 | ; ===end-group=== 147 | 148 | ===start-group=== "succ" 149 | --test-- "integer! -> integer!" 150 | y: succ 1 151 | z: 2 152 | --assert* [y == z] 153 | 154 | --test-- "float! -> float!" 155 | y: succ 1.2 156 | z: 2.2 157 | --assert* [(y - z) < 0.000001] 158 | 159 | --test-- "char! -> char! 1" 160 | y: succ #"a" 161 | z: #"b" 162 | --assert* [y == z] 163 | 164 | --test-- "char! -> char! 2" 165 | y: succ #"<" 166 | z: #"=" 167 | --assert* [y == z] 168 | ===end-group=== 169 | 170 | ===start-group=== "pred" 171 | --test-- "integer! -> integer!" 172 | y: pred 1 173 | z: 0 174 | --assert* [y == z] 175 | 176 | --test-- "float! -> float!" 177 | y: pred 1.2 178 | z: 0.2 179 | --assert* [(y - z) < 0.000001] 180 | 181 | --test-- "char! -> char! 1" 182 | y: pred #"b" 183 | z: #"a" 184 | --assert* [y == z] 185 | 186 | --test-- "char! -> char! 2" 187 | y: pred #"=" 188 | z: #"<" 189 | --assert* [y == z] 190 | 191 | --test-- "char! -> char! 3" 192 | y: pred (to-char 0) 193 | z: "none" 194 | --assert* [y == z] 195 | ===end-group=== 196 | 197 | ===start-group=== "range" 198 | --test-- "integer! -> integer! -> [integer!] 1" 199 | ys: range 1 5 200 | zs: [1 2 3 4 5] 201 | --assert* [ys == zs] 202 | 203 | --test-- "integer! -> integer! -> [integer!] 2" 204 | ys: range 0 0 205 | zs: [0] 206 | --assert* [ys == zs] 207 | 208 | --test-- "integer! -> integer! -> [integer!] 3" 209 | ys: range 9 0 210 | zs: [] 211 | --assert* [ys == zs] 212 | ===end-group=== 213 | 214 | ;;Numbers 215 | ===start-group=== "abs" 216 | --test-- "integer! -> integer! 1" 217 | y: 5 218 | z: abs -5 219 | --assert* [y == z] 220 | 221 | --test-- "integer! -> integer! 2" 222 | y: 5 223 | z: abs 5 224 | --assert* [y == z] 225 | 226 | --test-- "integer! -> integer! 3" 227 | y: 0 228 | z: abs 0 229 | --assert* [y == z] 230 | 231 | --test-- "float! -> float! 1" 232 | y: 1.2 233 | z: abs -1.2 234 | --assert* [y == z] 235 | 236 | --test-- "float! -> float! 2" 237 | y: 1.2 238 | z: abs 1.2 239 | --assert* [y == z] 240 | 241 | --test-- "float! -> float! 3" 242 | y: 0.0 243 | z: abs 0.0 244 | --assert* [y == z] 245 | ===end-group=== 246 | 247 | ===start-group=== "signum" 248 | --test-- "integer! -> integer! 1" 249 | y: -1 250 | z: signum -5 251 | --assert* [y == z] 252 | 253 | --test-- "integer! -> integer! 2" 254 | y: 1 255 | z: signum 5 256 | --assert* [y == z] 257 | 258 | --test-- "integer! -> integer! 3" 259 | y: 0 260 | z: signum 0 261 | --assert* [y == z] 262 | 263 | --test-- "float! -> float! 1" 264 | y: -1 265 | z: signum -1.2 266 | --assert* [y == z] 267 | 268 | --test-- "float! -> float! 2" 269 | y: 1 270 | z: signum 1.2 271 | --assert* [y == z] 272 | 273 | --test-- "float! -> float! 3" 274 | y: 0 275 | z: signum 0.0 276 | --assert* [y == z] 277 | ===end-group=== 278 | 279 | ===start-group=== "divMod" 280 | --test-- "integer! -> integer! -> integer! 1" 281 | y: [2 1] 282 | z: divMod 5 2 283 | --assert* [y == z] 284 | 285 | --test-- "integer! -> integer! -> integer! 2" 286 | y: [0 1] 287 | z: divMod 1 9 288 | --assert* [y == z] 289 | 290 | --test-- "integer! -> integer! -> integer3" 291 | y: [0 0] 292 | z: divMod 0 9 293 | --assert* [y == z] 294 | ===end-group=== 295 | 296 | ;;Numeric 297 | ===start-group=== "even" 298 | --test-- "integer! -> logic! 1" 299 | y: false 300 | z: even 1 301 | --assert* [y == z] 302 | 303 | --test-- "integer! -> logic! 2" 304 | y: true 305 | z: even 2 306 | --assert* [y == z] 307 | 308 | --test-- "integer! -> logic! 3" 309 | y: true 310 | z: even 0 311 | --assert* [y == z] 312 | ===end-group=== 313 | 314 | ===start-group=== "odd" 315 | --test-- "integer! -> logic! 1" 316 | y: true 317 | z: odd 1 318 | --assert* [y == z] 319 | 320 | --test-- "integer! -> logic! 2" 321 | y: false 322 | z: odd 2 323 | --assert* [y == z] 324 | 325 | --test-- "integer! -> logic! 3" 326 | y: false 327 | z: odd 0 328 | --assert* [y == z] 329 | ===end-group=== 330 | 331 | ===start-group=== "until'" 332 | --test-- "(integer! -> logic!) -> (integer! -> integer!) -> 1" 333 | f: [x] -> [x + 1] 334 | condition: [x] -> [x > 8] 335 | y: 9 336 | z: until' :condition :f 1 337 | --assert* [y == z] 338 | 339 | --test-- "(integer! -> logic!) -> (integer! -> integer!) -> 2" 340 | f: [x] -> [x - 1] 341 | condition: [x] -> [x < 8] 342 | y: 7 343 | z: until' :condition :f 20 344 | --assert* [y == z] 345 | ===end-group=== 346 | 347 | ;;Files 348 | ===start-group=== "doesFileExist" 349 | --test-- "file! -> logic!" 350 | y: true 351 | z: doesFileExist %all-test.red 352 | --assert* [y == z] 353 | ===end-group=== 354 | 355 | --test-- "string! -> logic!" 356 | y: true 357 | z: doesFileExist "all-test.red" 358 | --assert* [y == z] 359 | 360 | --test-- "string! -> logic!" 361 | y: false 362 | z: doesFileExist "abcd.red" 363 | --assert* [y == z] 364 | ===end-group=== 365 | 366 | ===start-group=== "readFile" 367 | --test-- "file! -> string!" 368 | y: true 369 | z: 0 < length? readFile %prelude-test.red 370 | --assert* [y == z] 371 | 372 | --test-- "string! -> string!" 373 | y: true 374 | z: 0 < length? readFile "./prelude-test.red" 375 | --assert* [y == z] 376 | 377 | --test-- "file! -> string!" 378 | y: none 379 | z: attempt [0 < length? readFile %/a/b/c/d] 380 | --assert* [y == z] 381 | ===end-group=== 382 | 383 | ===start-group=== "writeFile" 384 | --test-- "file! -> void!" 385 | path: %abcd.txt 386 | y: "hello" 387 | z: second reduce [(writeFile path "hello") (readFile path) (removeFile path)] 388 | --assert* [y == z] 389 | 390 | --test-- "string! -> void!" 391 | path: "abcd.txt" 392 | y: "hello" 393 | z: second reduce [(writeFile path "hello") (readFile path) (removeFile path)] 394 | --assert* [y == z] 395 | ===end-group=== 396 | 397 | ===start-group=== "appendFile" 398 | --test-- "file! -> void!" 399 | path: %abcd.txt 400 | y: "hellohello" 401 | z: third reduce [(appendFile path "hello") (appendFile path "hello") (readFile path) (removeFile path)] 402 | --assert* [y == z] 403 | 404 | --test-- "string! -> void!" 405 | path: "abcd.txt" 406 | y: "hellohello" 407 | z: third reduce [(appendFile path "hello") (appendFile path "hello") (readFile path) (removeFile path)] 408 | --assert* [y == z] 409 | ===end-group=== 410 | 411 | ===start-group=== "doesFileExist" 412 | --test-- "file! -> void!" 413 | path: %abcd.txt 414 | y: false 415 | z: third reduce [(appendFile path "hello") (removeFile path) (doesFileExist path)] 416 | --assert* [y == z] 417 | 418 | --test-- "string! -> void!" 419 | path: "abcd.txt" 420 | y: false 421 | z: third reduce [(appendFile path "hello") (removeFile path) (doesFileExist path)] 422 | --assert* [y == z] 423 | ===end-group=== 424 | 425 | ~~~end-file~~~ -------------------------------------------------------------------------------- /prelude.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Prelude" 3 | Author: "unchartedworks" 4 | File: %prelude.red 5 | Tabs: 4 6 | Rights: "unchartedworks. All rights reserved." 7 | License: "MIT" 8 | ] 9 | 10 | and*: function [ 11 | "Boolean and" 12 | x [logic!] 13 | y [logic!] 14 | ][ 15 | either x == y [ 16 | either x == true [true][false] 17 | ][ 18 | false 19 | ] 20 | ] 21 | &&: make op! :and* 22 | 23 | or*: function [ 24 | "Boolean or" 25 | x [logic!] 26 | y [logic!] 27 | ][ 28 | either x == true [ 29 | true 30 | ][ 31 | either y == true [true][false] 32 | ] 33 | ] 34 | ||: make op! :or* 35 | 36 | not': function [ 37 | "Boolean not" 38 | x [logic!] 39 | ][ 40 | either x == true [false][true] 41 | ] 42 | 43 | otherwise: function [ 44 | "otherwise is defined as the value True" 45 | ][ 46 | true 47 | ] 48 | 49 | fst: function [ 50 | "Extract the first component of a pair." 51 | xs [pair! series!] 52 | ][ 53 | case [ 54 | (pair? xs) (first xs) 55 | ((series? xs) && (2 == (length? xs))) (first xs) 56 | otherwise (cause-error 'script 'invalid-arg [xs]) 57 | ] 58 | ] 59 | 60 | snd: function [ 61 | "Extract the second component of a pair." 62 | xs [pair! series!] 63 | ][ 64 | case [ 65 | (pair? xs) (second xs) 66 | ((series? xs) && (2 == (length? xs))) (last xs) 67 | otherwise (cause-error 'script 'invalid-arg [xs]) 68 | ] 69 | ] 70 | 71 | ; curry: function [ 72 | ; "curry converts an uncurried function to a curried function." 73 | ; f [any-function!] 74 | ; x 75 | ; ][ 76 | ; func [y] reduce [:f :x 'y] 77 | ; ] 78 | 79 | ; uncurry: function [ 80 | ; "curry converts an curried function to a uncurried function." 81 | ; f [any-function!] 82 | ; x 83 | ; ][ 84 | ; func [y] reduce [:f :x 'y] 85 | ; ] 86 | 87 | ;;Enum 88 | succ: function [ 89 | "the successor of a value. For numeric types, succ adds 1." 90 | x 91 | ][ 92 | case [ 93 | (number? x) (x + 1) 94 | (char? x) (to-char (1 + to-integer x)) 95 | true "none"] 96 | ] 97 | 98 | pred: function [ 99 | "the predecessor of a value. For numeric types, pred subtracts 1." 100 | x 101 | ][ 102 | case [ 103 | (number? x) (x - 1) 104 | (char? x) && ((to-integer x) > 0) (to-char ((to-integer x) - 1)) 105 | true "none"] 106 | ] 107 | 108 | range: function [ 109 | "generates the list [imin ... imax]." 110 | imin [number!] 111 | imax [number!] 112 | ][ 113 | either negative? (imax - imin) [copy []][range* imin imax] 114 | ] 115 | range*: function [imin imax][ 116 | xs: copy reduce [imin] 117 | len: imax - imin 118 | repeat i :len [ 119 | xs: xs ++ reduce [imin + i] 120 | ] 121 | xs 122 | ] 123 | 124 | enumFromTo: :range 125 | 126 | ;;Numbers 127 | ;;negate 128 | abs: :absolute 129 | 130 | signum: function [ 131 | x [number!] 132 | ][ 133 | case [ 134 | (positive? x) 1 135 | (negative? x) -1 136 | otherwise 0 137 | ] 138 | ] 139 | 140 | div: :divide 141 | ;;mod 142 | 143 | divMod: function [ 144 | "simultaneous div and mod" 145 | m [integer!] 146 | n [integer!] 147 | ][ 148 | reduce [(divide m n) (mod m n)] 149 | ] 150 | 151 | toInteger: :to-integer 152 | 153 | ;;Numeric 154 | even: function [ 155 | x 156 | ][ 157 | either 0 == (mod x 2) [true][false] 158 | ] 159 | 160 | odd: function [ 161 | x 162 | ][ 163 | either 1 == (mod x 2) [true][false] 164 | ] 165 | 166 | ;;Misc 167 | until': function [ 168 | "until p f yields the result of applying f until p holds." 169 | condition [any-function!] 170 | f [any-function!] 171 | x 172 | ][ 173 | y: x 174 | until [ 175 | y: f y 176 | condition y 177 | ] 178 | y 179 | ] 180 | 181 | ;;Files 182 | doesFileExist: function [ 183 | "if the argument file exists and is not a directory, and False otherwise" 184 | x [file! string!] 185 | ][ 186 | path: either string? x [to-file x][x] 187 | exists? path 188 | ] 189 | 190 | readFile: function [ 191 | "The readFile function reads a file and returns the contents of the file as a string." 192 | x [file! string!] 193 | ][ 194 | read either string? x [to-file x][x] 195 | ] 196 | 197 | writeFile: function [ 198 | "The computation writeFile file str function writes the string str, to the file file." 199 | file [file! string!] 200 | xs [string!] 201 | ][ 202 | path: either string? file [to-file file][file] 203 | write path xs 204 | ] 205 | 206 | appendFile: function [ 207 | "The computation appendFile file str function appends the string str, to the file file." 208 | file [file! string!] 209 | xs [string!] 210 | ][ 211 | path: either string? file [to-file file][file] 212 | write/append path xs 213 | ] 214 | 215 | removeFile: function [ 216 | "The computation appendFile file str function appends the string str, to the file file." 217 | file [file! string!] 218 | ][ 219 | path: either string? file [to-file file][file] 220 | delete path 221 | ] 222 | -------------------------------------------------------------------------------- /quick-test/quick-test.r: -------------------------------------------------------------------------------- 1 | REBOL [ 2 | Title: "Simple testing framework for Red and Red/System programs" 3 | Author: "Peter W A Wood" 4 | File: %quick-test.r 5 | Version: 0.12.0 6 | Tabs: 4 7 | Rights: "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved." 8 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 9 | ] 10 | 11 | comment { 12 | This script makes some assumptions about the directory structure in which 13 | files are stored. They are: 14 | this script is stored in Red/quick-test/ 15 | the Red & Red/System compiler is stored in Red/ 16 | the default dir for tests is Red/system/tests/ 17 | 18 | The default test dirs can be overriden by setting qt/tests-dir before 19 | tests are processed 20 | The default script header for code supplied as string is Red [], this 21 | can be overriden by setting qt/script-header 22 | The default location of the compiler binary is Red/build/bin, this can 23 | be overriden by setting qt/bin-compiler 24 | } 25 | 26 | qt: make object! [ 27 | 28 | ;;;;;;;;;;; Setup ;;;;;;;;;;;;;; 29 | ;; set the base-dir to ....Red/ 30 | base-dir: system/script/path 31 | base-dir: copy/part base-dir find base-dir "quick-test" 32 | ;; set the red/system runnable dir 33 | runnable-dir: dirize base-dir/quick-test/runnable 34 | ;; set the default base dir for tests 35 | tests-dir: dirize base-dir/system/tests 36 | 37 | ;; set the version number 38 | version: system/script/header/version 39 | 40 | ;; switch for binary compiler usage 41 | binary-compiler?: false 42 | 43 | ;; check if call-show? is enabled for call 44 | either any [ 45 | not value? 'call-show? 46 | equal? call-show? 'wait 47 | ] [call-show?: 'wait] [call-show?: 'show] 48 | call*: to path! 'call 49 | append call* :call-show? 50 | append call* 'output 51 | 52 | ;; default binary compiler path 53 | bin-compiler: base-dir/build/bin/red 54 | 55 | ;; default script header to be inserted into code supplied in string form 56 | script-header: "Red []" 57 | 58 | ;; set temporary files names 59 | ;; use Red/quick-test/runnable for temp files 60 | comp-echo: runnable-dir/comp-echo.txt 61 | comp-r: runnable-dir/comp.r 62 | test-src-file: runnable-dir/qt-test-comp.red 63 | 64 | ;; set log file 65 | log-file: join system/script/path "quick-test.log" 66 | 67 | ;; make runnable directory if needed 68 | make-dir runnable-dir 69 | 70 | ;; windows ? 71 | windows-os?: system/version/4 = 3 72 | 73 | ;; use Cheyenne call with REBOL v2.7.8 on Windows (re: 'call bug on Windows 7) 74 | if all [ 75 | windows-os? 76 | system/version/3 = 8 77 | ][ 78 | do %../utils/call.r 79 | set 'call :win-call 80 | ] 81 | 82 | ;; script header parse rules - assumes parsing without /all 83 | red?: false 84 | red-header: ["red" any " " "[" to end (red?: true)] 85 | red-system-header: ["red/system" any " " "[" to end (red?: false)] 86 | red?-rule: [(red?: false) any [red-system-header | red-header | skip]] 87 | script-header-rule: [ 88 | (no-script-header?: true) 89 | any [ 90 | [["red/system" | "red"] any " " "[" (no-script-header?: false)] 91 | | 92 | skip 93 | ] 94 | ] 95 | 96 | ;;;;;;;;; End Setup ;;;;;;;;;;;;;; 97 | 98 | comp-output: copy "" ;; output captured from compile 99 | output: copy "" ;; output captured from pgm exec 100 | exe: none ;; filepath to executable 101 | source-file?: true ;; true = running test file 102 | ;; false = runnning test script 103 | 104 | 105 | summary-template: ".. - .................................................. / " 106 | 107 | data: make object! [ 108 | title: copy "" 109 | no-tests: 0 110 | no-asserts: 0 111 | passes: 0 112 | failures: 0 113 | reset: does [ 114 | title: copy "" 115 | no-tests: 0 116 | no-asserts: 0 117 | passes: 0 118 | failures: 0 119 | ] 120 | ] 121 | 122 | file: make data [] 123 | test-run: make data [] 124 | _add-file-to-run-totals: does [ 125 | test-run/no-tests: test-run/no-tests + file/no-tests 126 | test-run/no-asserts: test-run/no-asserts + file/no-asserts 127 | test-run/passes: test-run/passes + file/passes 128 | test-run/failures: test-run/failures + file/failures 129 | ] 130 | _signify-failure: does [ 131 | ;; called when a compiler or runtime error occurs 132 | file/failures: file/failures + 1 133 | file/no-tests: file/no-tests + 1 134 | file/no-asserts: file/no-asserts + 1 135 | test-run/failures: test-run/failures + 1 136 | test-run/no-tests: test-run/no-tests + 1 137 | test-run/no-asserts: test-run/no-asserts + 1 138 | ] 139 | 140 | ;; group data 141 | group-name: copy "" 142 | group?: false 143 | group-name-not-printed: true 144 | _init-group: does [ 145 | group?: false 146 | group-name-not-printed: true 147 | group-name: copy "" 148 | ] 149 | 150 | ;; test data 151 | test-name: copy "" 152 | _init-test: does [ 153 | test-name: copy "" 154 | ] 155 | 156 | ;; print diversion function 157 | _save-print: :print 158 | print-output: copy "" 159 | _quiet-print: func [val] [ 160 | append print-output join "" [reduce val "^/"] 161 | ] 162 | 163 | compile: func [ 164 | src [file!] 165 | /bin 166 | /lib 167 | target [string!] 168 | /local 169 | comp ;; compilation script 170 | cmd ;; compilation cmd 171 | exe ;; executable name 172 | ][ 173 | clear comp-output 174 | 175 | ;; workout executable name 176 | either find/last/tail src "/" [ 177 | exe: copy find/last/tail src "/" 178 | ][ 179 | exe: copy src 180 | ] 181 | exe: copy/part exe find exe "." 182 | either lib [ 183 | switch/default target [ 184 | "Windows" [exe: join exe [".dll"]] 185 | "Darwin" [exe: join exe [".dylib"]] 186 | ][ 187 | exe: join exe [".so"] 188 | ] 189 | exe 190 | ][ 191 | if windows-os? [ 192 | exe: join exe [".exe"] 193 | ] 194 | ] 195 | 196 | ;; find the path to the src 197 | if #"/" <> first src [src: tests-dir/:src] ;; relative path supplied 198 | 199 | ;; red/system or red 200 | red?: false 201 | parse read src red?-rule 202 | 203 | ;; compose and write compilation script 204 | either binary-compiler? [ 205 | if #"/" <> first src [src: tests-dir/:src] ;; relative path supplied 206 | either lib [ 207 | cmd: join "" [to-local-file bin-compiler " -o " 208 | to-local-file runnable-dir/:exe 209 | " -dlib -t " target " " 210 | to-local-file src 211 | ] 212 | ][ 213 | cmd: join "" [to-local-file bin-compiler " -o " 214 | to-local-file runnable-dir/:exe " " 215 | to-local-file src 216 | ] 217 | ] 218 | comp-output: make string! 1024 219 | do call* cmd comp-output 220 | ][ 221 | comp: mold compose/deep [ 222 | REBOL [] 223 | halt: :quit 224 | echo (comp-echo) 225 | do/args (reduce base-dir/red.r) (join " -o " [ 226 | reduce runnable-dir/:exe " ###lib###***src***" 227 | ]) 228 | echo none 229 | ] 230 | either lib [ 231 | replace comp "###lib###" join "-dlib -t " [target " "] 232 | ][ 233 | replace comp "###lib###" "" 234 | ] 235 | 236 | replace comp "***src***" clean-path src 237 | write comp-r comp 238 | 239 | ;; compose command line and call it 240 | cmd: join to-local-file system/options/boot [" -sc " comp-r] 241 | do call* cmd make string! 1024 ;; redirect output to anonymous 242 | ;; buffer 243 | ] 244 | 245 | ;; collect compiler output & tidy up 246 | if exists? comp-echo [ 247 | comp-output: read comp-echo 248 | delete comp-echo 249 | ] 250 | if exists? comp-r [delete comp-r] 251 | recycle 252 | either compile-ok? [ 253 | exe 254 | ][ 255 | none 256 | ] 257 | ] 258 | 259 | compile-and-run: func [src /error /pgm] [ 260 | source-file?: true 261 | either exe: compile src [ 262 | either error [ 263 | run/error exe 264 | ][ 265 | either pgm [ 266 | run/pgm exe 267 | ][ 268 | run exe 269 | ] 270 | ] 271 | ][ 272 | compile-error src 273 | output: "Compilation failed" 274 | ] 275 | ] 276 | 277 | compile-and-run-from-string: func [src /error] [ 278 | source-file?: false 279 | either exe: compile-from-string src [ 280 | either error [ 281 | run/error exe 282 | ][ 283 | run exe 284 | ] 285 | ][ 286 | 287 | compile-error "Supplied source" 288 | output: "Compilation failed" 289 | ] 290 | ] 291 | 292 | compile-dll: func [ 293 | lib-src [file!] 294 | target [string!] 295 | /local 296 | dll 297 | ][ 298 | ;; compile the lib into the runnable dir 299 | if not dll: compile/lib lib-src target [ 300 | compile-error lib-src 301 | output: "Lib compilation failed" 302 | ] 303 | dll 304 | ] 305 | 306 | compile-from-string: func [src][ 307 | ;-- add a default header if not provided 308 | parse src script-header-rule 309 | if no-script-header? [ 310 | insert src join script-header "^/" 311 | ] 312 | write test-src-file src 313 | compile test-src-file ;; returns path to executable or none 314 | ] 315 | 316 | compile-error: func [ 317 | src [file! string!] 318 | ][ 319 | print join "^/" [src " - compiler error^/"] 320 | print comp-output 321 | print newline 322 | clear output ;; clear the output from previous test 323 | _signify-failure 324 | ] 325 | 326 | compile-ok?: func [] [ 327 | either find comp-output "output file size :" [true] [false] 328 | ] 329 | 330 | compile-run-print: func [src [file!] /error][ 331 | either error [ 332 | compile-and-run/error src 333 | ][ 334 | compile-and-run src 335 | ] 336 | if output <> "Compilation failed" [print output] 337 | ] 338 | 339 | compiled?: func [ 340 | src [string!] 341 | ][ 342 | exe: compile-from-string src 343 | clean-compile-from-string 344 | qt/compile-ok? 345 | ] 346 | 347 | run: func [ 348 | prog [file!] 349 | ;;/args ;; not yet needed 350 | ;;parms [string!] ;; not yet needed 351 | /error ;; run time error expected 352 | /pgm ;; a program not a test 353 | /local 354 | exec [string!] ;; command to be executed 355 | ][ 356 | exec: to-local-file runnable-dir/:prog 357 | ;;exec: join "" compose/deep [(exec either args [join " " parms] [""])] 358 | clear output 359 | do call* exec output 360 | ;;if all [red? windows-os?] [output: qt/utf-16le-to-utf-8 output] 361 | recycle 362 | if all [ 363 | source-file? 364 | not pgm 365 | any [ 366 | all [ 367 | none <> find output "Runtime Error" 368 | not error 369 | ] 370 | none = find output "Passed" 371 | ] 372 | ][ 373 | print "signify failure" 374 | _signify-failure 375 | ] 376 | ] 377 | 378 | run-unit-test: func [ 379 | src [file!] 380 | /local 381 | cmd ;; command to run 382 | output 383 | test-name 384 | ][ 385 | source-file?: false 386 | do join tests-dir src 387 | ] 388 | 389 | run-unit-test-quiet: func [ 390 | src [file!] 391 | /local 392 | cmd ;; command to run 393 | test-name 394 | ][ 395 | file/reset 396 | source-file?: false 397 | test-name: find/last/tail src "/" 398 | test-name: copy/part test-name find test-name "." 399 | prin [ "running " test-name #"^(0D)"] 400 | clear output 401 | cmd: join to-local-file system/options/boot [" -sc " tests-dir src] 402 | do call* cmd output 403 | if find output "Error:" [_signify-failure] 404 | add-to-run-totals 405 | write/append log-file output 406 | file/title: test-name 407 | replace file/title "-test" "" 408 | _print-summary file 409 | ] 410 | 411 | run-script: func [ 412 | src [file!] 413 | /local 414 | filename ;; filename of script 415 | script ;; %runnable/filename 416 | ][ 417 | if not filename: copy find/last/tail src "/" [filename: copy src] 418 | script: runnable-dir/:filename 419 | write to file! script read join tests-dir [src] 420 | if error? try [do script] [_signify-failure] 421 | ] 422 | 423 | run-script-quiet: func [ 424 | src [file!] 425 | ][ 426 | prin [ "running " find/last/tail src "/" #"^(0D)"] 427 | print: :_quiet-print 428 | print-output: copy "" 429 | run-script src 430 | add-to-run-totals 431 | print: :_save-print 432 | write/append log-file print-output 433 | _print-summary file 434 | ] 435 | 436 | run-test-file: func [ 437 | src [file!] 438 | ][ 439 | file/reset 440 | unless file/title: find/last/tail to string! src "/" [file/title: src] 441 | replace file/title "-test.reds" "" 442 | replace file/title "-test.red" "" 443 | compile-run-print src 444 | add-to-run-totals 445 | ] 446 | 447 | run-test-file-quiet: func [ 448 | src [file!] 449 | ][ 450 | prin [ "running " find/last/tail src "/" #"^(0D)"] 451 | print: :_quiet-print 452 | print-output: copy "" 453 | run-test-file src 454 | print: :_save-print 455 | write/append log-file print-output 456 | _print-summary file 457 | output: copy "" 458 | ] 459 | 460 | add-to-run-totals: func [ 461 | /local 462 | tests 463 | 464 | asserts 465 | passes 466 | failures 467 | rule 468 | digit 469 | number 470 | ][ 471 | digit: charset [#"0" - #"9"] 472 | number: [some digit] 473 | ws: charset [#"^-" #"^/" #" "] 474 | whitespace: [some ws] 475 | rule: [ 476 | thru "Number of Tests Performed:" whitespace copy tests number 477 | thru "Number of Assertions Performed:" whitespace copy asserts number 478 | thru "Number of Assertions Passed:" whitespace copy passed number 479 | thru "Number of Assertions Failed:" whitespace copy failures number 480 | to end 481 | ] 482 | if parse/all output rule [ 483 | file/no-tests: file/no-tests + to integer! tests 484 | file/no-asserts: file/no-asserts + to integer! asserts 485 | file/passes: file/passes + to integer! passed 486 | file/failures: file/failures + to integer! failures 487 | _add-file-to-run-totals 488 | ] 489 | ] 490 | 491 | _start: func [ 492 | data [object!] 493 | leader [string!] 494 | title [string!] 495 | ][ 496 | print [leader title] 497 | data/title: title 498 | data/no-tests: 0 499 | data/no-asserts: 0 500 | data/passes: 0 501 | data/failures: 0 502 | _init-group 503 | ] 504 | 505 | start-test-run: func [ 506 | title [string!] 507 | ][ 508 | _start test-run "***Starting***" title 509 | prin newline 510 | ] 511 | 512 | start-test-run-quiet: func [ 513 | title [string!] 514 | ][ 515 | _start test-run "" title 516 | prin newline 517 | write log-file rejoin ["***Starting*** " title newline] 518 | ] 519 | 520 | start-file: func [ 521 | title [string!] 522 | ][ 523 | _start file "~~~started test~~~" title 524 | ] 525 | 526 | start-group: func[ 527 | title [string!] 528 | ][ 529 | group-name: title 530 | group?: true 531 | ] 532 | 533 | start-test: func[ 534 | title [string!] 535 | ][ 536 | _init-test 537 | test-name: title 538 | file/no-tests: file/no-tests + 1 539 | ] 540 | 541 | assert: func [ 542 | assertion [logic!] 543 | ][ 544 | file/no-asserts: file/no-asserts + 1 545 | either assertion [ 546 | file/passes: file/passes + 1 547 | ][ 548 | file/failures: file/failures + 1 549 | if group? [ 550 | if group-name-not-printed [ 551 | print "" 552 | print ["===group===" group-name] 553 | ] 554 | ] 555 | print ["---test---" test-name "FAILED**************"] 556 | ] 557 | ] 558 | 559 | assert-msg?: func [msg][ 560 | assert found? find qt/comp-output msg 561 | ] 562 | 563 | assert-printed?: func [msg] [ 564 | assert found? find qt/output msg 565 | ] 566 | 567 | clean-compile-from-string: does [ 568 | if exists? test-src-file [delete test-src-file] 569 | if all [exe exists? exe][delete exe] 570 | ] 571 | 572 | end-group: does [ 573 | _init-group 574 | ] 575 | 576 | _end: func [ 577 | data [object!] 578 | leader [string!] 579 | ][ 580 | print [leader data/title] 581 | print ["No of tests " data/no-tests] 582 | print ["No of asserts" data/no-asserts] 583 | print ["Passed " data/passes] 584 | print ["Failed " data/failures] 585 | if data/failures > 0 [print "***TEST FAILURES***"] 586 | print "" 587 | ] 588 | 589 | end-file: func [] [ 590 | _end file "~~~finished test~~~" 591 | _add-file-to-run-totals 592 | ] 593 | 594 | end-test-run: func [] [ 595 | print "" 596 | _end test-run "***Finished***" 597 | ] 598 | 599 | end-test-run-quiet: func [] [ 600 | print: :_quiet-print 601 | print-output: copy "" 602 | end-test-run 603 | print: :_save-print 604 | write/append log-file print-output 605 | prin newline 606 | _print-summary test-run 607 | ] 608 | 609 | _print-summary: func [ 610 | data [object!] 611 | /local 612 | print-line 613 | ][ 614 | print-line: copy summary-template 615 | print-line: skip print-line 5 616 | remove/part print-line length? data/title 617 | insert print-line data/title 618 | print-line: skip tail print-line negate (3 + length? mold data/passes) 619 | remove/part print-line length? mold data/passes 620 | insert print-line data/passes 621 | append print-line data/no-asserts 622 | print-line: head print-line 623 | either data/no-asserts = data/passes [ 624 | replace print-line ".." "ok" 625 | ][ 626 | replace/all print-line "." "*" 627 | append print-line " **" 628 | ] 629 | print print-line 630 | ] 631 | 632 | make-if-needed?: func [ 633 | {This function is used by the Red run-all scripts to build the auto files 634 | when necessary.} 635 | auto-test-file [file!] 636 | make-file [file!] 637 | /lib-test 638 | /local 639 | stored-length ; the length of the make... .r file used to build auto tests 640 | stored-file-length 641 | digit 642 | number 643 | rule 644 | ][ 645 | auto-test-file: join tests-dir auto-test-file 646 | make-file: join tests-dir make-file 647 | 648 | stored-file-length: does [ 649 | parse/all read auto-test-file rule 650 | stored-length 651 | ] 652 | digit: charset [#"0" - #"9"] 653 | number: [some digit] 654 | rule: [ 655 | thru ";make-length:" 656 | copy stored-length number (stored-length: to integer! stored-length) 657 | to end 658 | ] 659 | 660 | if not exists? make-file [return] 661 | 662 | if any [ 663 | not exists? auto-test-file 664 | stored-file-length <> length? read make-file 665 | 0:00 < difference modified? make-file modified? auto-test-file 666 | ][ 667 | print ["Making" auto-test-file " - it will take a while"] 668 | do make-file 669 | ] 670 | ] 671 | 672 | setup-temp-files: func [ 673 | /local 674 | f 675 | ][ 676 | foreach file read runnable-dir [attempt [delete runnable-dir/:file]] 677 | 678 | f: to string! now/time/precise 679 | f: replace/all f ":" "" 680 | f: replace/all f "." "" 681 | comp-echo: join runnable-dir ["comp-echo" f ".txt"] 682 | comp-r: join runnable-dir ["comp" f ".r"] 683 | test-src-file: join runnable-dir ["qt-test-comp" f ".red"] 684 | ] 685 | 686 | delete-temp-files: does [ 687 | if exists? comp-echo [delete comp-echo] 688 | if exists? comp-r [delete comp-r] 689 | if exists? test-src-file [delete test-src-file] 690 | ] 691 | 692 | seperate-log-file: func [ 693 | /local 694 | f 695 | ][ 696 | f: to string! now/time/precise 697 | f: replace/all f ":" "" 698 | f: replace/all f "." "" 699 | log-file: join base-dir ["quick-test/quick-test" f ".log"] 700 | ] 701 | 702 | utf-16le-to-utf-8: func [ 703 | {Translates a utf-16LE encoded string to an utf-8 encoded one 704 | the algorithm is copied from lexer.r } 705 | in-str [string!] 706 | /local 707 | out-str 708 | code 709 | ][ 710 | out-str: copy "" 711 | foreach [low high] to binary! in-str [ 712 | code: high * 256 + low 713 | case [ 714 | code <= 127 [ 715 | append out-str to char! code ;-- c <= 7Fh 716 | ] 717 | code <= 2047 [ ;-- c <= 07FFh 718 | append out-str join "" [ 719 | to char! ((shift code 6) and #"^(1F)" or #"^(C0)") 720 | to char! ((code and #"^(3F)") or #"^(80)") 721 | ] 722 | ] 723 | code <= 65535 [ ;-- c <= FFFFh 724 | append out-str join "" [ 725 | to char! ((shift code 12) and #"^(0F)" or #"^(E0)") 726 | to char! ((shift code 6) and #"^(3F)" or #"^(80)") 727 | to char! (code and #"^(3F)" or #"^(80)") 728 | ] 729 | ] 730 | code <= 1114111 [ ;-- c <= 10FFFFh 731 | append out-str join "" [ 732 | to char! ((shift code 18) & ^"(07)" or #"^(F0)") 733 | to char! ((shift code 12) and #"^(3F)" or #"^(80)") 734 | to char! ((shift code 6) and #"^(3F)" or #"^(80)") 735 | to char! (code and #"^(3F)" or #"^(80)") 736 | ] 737 | ] ;-- Codepoints above U+10FFFF are ignored" 738 | ] 739 | ] 740 | out-str 741 | ] 742 | 743 | ;; create the test "dialect" 744 | 745 | set '***start-run*** :start-test-run 746 | set '***start-run-quiet*** :start-test-run-quiet 747 | set '~~~start-file~~~ :start-file 748 | set '===start-group=== :start-group 749 | set '--test-- :start-test 750 | set '--compile :compile 751 | set '--compile-red :compile 752 | set '--compile-dll :compile-dll 753 | set '--compile-this :compile-from-string 754 | set '--compile-this-red :compile-from-string 755 | set '--compile-and-run :compile-and-run 756 | set '--compile-and-run-red :compile-and-run 757 | set '--compile-and-run-this :compile-and-run-from-string 758 | set '--compile-and-run-this-red :compile-and-run-from-string 759 | set '--compile-run-print :compile-run-print 760 | set '--compile-run-print-red :compile-run-print 761 | set '--compiled? :compiled? 762 | set '--run :run 763 | set '--add-to-run-totals :add-to-run-totals 764 | set '--run-unit-test :run-unit-test 765 | set '--run-unit-test-quiet :run-unit-test-quiet 766 | set '--run-script :run-script 767 | set '--run-script-quiet :run-script-quiet 768 | set '--run-test-file :run-test-file 769 | set '--run-test-file-red :run-test-file 770 | set '--run-test-file-quiet :run-test-file-quiet 771 | set '--run-test-file-quiet-red :run-test-file-quiet 772 | set '--assert :assert 773 | set '--assert-msg? :assert-msg? 774 | set '--assert-printed? :assert-printed? 775 | set '--assert-red-printed? :assert-printed? 776 | set '--clean :clean-compile-from-string 777 | set '===end-group=== :end-group 778 | set '~~~end-file~~~ :end-file 779 | set '***end-run*** :end-test-run 780 | set '***end-run-quiet*** :end-test-run-quiet 781 | set '--setup-temp-files :setup-temp-files 782 | set '--delete-temp-files :delete-temp-files 783 | set '--seperate-log-file :seperate-log-file 784 | ] 785 | -------------------------------------------------------------------------------- /quick-test/quick-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Red simple testing framework" 3 | Author: "Peter W A Wood" 4 | File: %quick-test.red 5 | Version: "0.2.0" 6 | Rights: "Copyright (C) 2012-2015 Peter W A Wood. All rights reserved." 7 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 8 | ] 9 | 10 | ;; counters 11 | #either any [ 12 | not in system 'state 13 | not system/state/interpreted? 14 | ][ 15 | qt-run-tests: 0 16 | qt-run-asserts: 0 17 | qt-run-passes: 0 18 | qt-run-failures: 0 19 | qt-file-tests: 0 20 | qt-file-asserts: 0 21 | qt-file-passes: 0 22 | qt-file-failures: 0 23 | ][ 24 | if not value? 'qt-run-tests [ 25 | qt-run-tests: 0 26 | qt-run-asserts: 0 27 | qt-run-passes: 0 28 | qt-run-failures: 0 29 | qt-file-tests: 0 30 | qt-file-asserts: 0 31 | qt-file-passes: 0 32 | qt-file-failures: 0 33 | ] 34 | ] 35 | qt-file-name: none 36 | 37 | ;; group switches 38 | qt-group-name-not-printed: true 39 | qt-group?: false 40 | 41 | _qt-init-group: func [] [ 42 | qt-group-name-not-printed: true 43 | qt-group?: false 44 | qt-group-name: "" 45 | ] 46 | 47 | qt-init-run: func [] [ 48 | qt-run-tests: 0 49 | qt-run-asserts: 0 50 | qt-run-passes: 0 51 | qt-run-failures: 0 52 | _qt-init-group 53 | ] 54 | 55 | qt-init-file: func [] [ 56 | qt-file-tests: 0 57 | qt-file-asserts: 0 58 | qt-file-passes: 0 59 | qt-file-failures: 0 60 | _qt-init-group 61 | ] 62 | 63 | ***start-run***: func[ 64 | title [string!] 65 | ][ 66 | qt-init-run 67 | qt-run-name: title 68 | prin "***Starting*** " 69 | print title 70 | ] 71 | 72 | ~~~start-file~~~: func [ 73 | title [string!] 74 | ][ 75 | qt-init-file 76 | prin "~~~started test~~~ " 77 | print title 78 | qt-file-name: title 79 | qt-group?: false 80 | ] 81 | 82 | ===start-group===: func [ 83 | title [string!] 84 | ][ 85 | qt-group-name: title 86 | qt-group?: true 87 | ] 88 | 89 | --test--: func [ 90 | title [string!] 91 | ][ 92 | qt-test-name: title 93 | qt-file-tests: qt-file-tests + 1 94 | ] 95 | 96 | --assert: func [ 97 | assertion [logic!] 98 | ][ 99 | 100 | qt-file-asserts: qt-file-asserts + 1 101 | 102 | either assertion [ 103 | qt-file-passes: qt-file-passes + 1 104 | ][ 105 | qt-file-failures: qt-file-failures + 1 106 | if qt-group? [ 107 | if qt-group-name-not-printed [ 108 | prin "===group=== " 109 | print qt-group-name 110 | qt-group-name-not-printed: false 111 | ] 112 | ] 113 | prin "--test-- " 114 | prin qt-test-name 115 | print " FAILED**************" 116 | ] 117 | ] 118 | 119 | --assert*: func [ 120 | assertion-block [block!] 121 | /local assertion 122 | ][ 123 | assertion: do assertion-block 124 | --assert assertion 125 | if not assertion [ 126 | call "osascript -e 'beep'" 127 | print-assertion-block assertion-block 128 | ] 129 | ] 130 | 131 | print-assertion-block: func [ 132 | assertion-block [block!] 133 | ][ 134 | nonOp?: func [x][none == find ops to-string x] 135 | ops: ["%" "*" "**" "+" "-" "..." "/" "//" "<" "<<" "<=" "<>" "=" "==" "=?" ">" ">=" ">>" ">>>" "and" "is" "or" "xor"] 136 | conditional-do: func [x][either nonOp? x [mold (do x)] [form x]] 137 | print map :conditional-do (load form assertion-block) 138 | ] 139 | 140 | --assertf~=: func[ 141 | x [float!] 142 | y [float!] 143 | e [float!] 144 | /local 145 | diff [float!] 146 | e1 [float!] 147 | e2 [float!] 148 | ][ 149 | ;; calculate tolerance to use 150 | ;; as e * max (1, x, y) 151 | either x > 0.0 [ 152 | e1: x * e 153 | ][ 154 | e1: -1.0 * x * e 155 | ] 156 | if e > e1 [e1: e] 157 | either y > 0.0 [ 158 | e2: y * e 159 | ][ 160 | e2: -1.0 * y * e 161 | ] 162 | if e1 > e2 [e2: e1] 163 | 164 | ;; perform almost equal check 165 | either x > y [ 166 | diff: x - y 167 | ][ 168 | diff: y - x 169 | ] 170 | either diff > e2 [ 171 | --assert false 172 | ][ 173 | --assert true 174 | ] 175 | ] 176 | 177 | ===end-group===: func [] [ 178 | _qt-init-group 179 | ] 180 | 181 | qt-print-totals: func [ 182 | tests [integer!] 183 | asserts [integer!] 184 | passes [integer!] 185 | failures [integer!] 186 | ][ 187 | prin " Number of Tests Performed: " 188 | print tests 189 | prin " Number of Assertions Performed: " 190 | print asserts 191 | prin " Number of Assertions Passed: " 192 | print passes 193 | prin " Number of Assertions Failed: " 194 | print failures 195 | if failures <> 0 [ 196 | print "****************TEST FAILURES****************" 197 | ] 198 | ] 199 | 200 | ~~~end-file~~~: func [] [ 201 | print ["~~~finished test~~~ " qt-file-name] 202 | qt-print-totals qt-file-tests qt-file-asserts qt-file-passes qt-file-failures 203 | print "" 204 | 205 | ;; update run totals 206 | qt-run-passes: qt-run-passes + qt-file-passes 207 | qt-run-asserts: qt-run-asserts + qt-file-asserts 208 | qt-run-failures: qt-run-failures + qt-file-failures 209 | qt-run-tests: qt-run-tests + qt-file-tests 210 | ] 211 | 212 | ***end-run***: func [][ 213 | prin "***Finished*** " 214 | print qt-run-name 215 | qt-print-totals qt-run-tests 216 | qt-run-asserts 217 | qt-run-passes 218 | qt-run-failures 219 | ] 220 | -------------------------------------------------------------------------------- /quick-test/quick-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System simple testing framework" 3 | Author: "Peter W A Wood" 4 | File: %quick-test.reds 5 | Version: 0.4.2 6 | Tabs: 4 7 | Rights: "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved." 8 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 9 | ] 10 | 11 | ;; allocate string memory 12 | qt-run-name: "123456789012345678901234567890" 13 | qt-file-name: "123456789012345678901234567890" 14 | qt-group-name: "123456789012345678901234567890" 15 | qt-test-name: "123456789012345678901234567890" 16 | 17 | ;; counters 18 | qt-run: declare struct! [ 19 | tests [integer!] 20 | asserts [integer!] 21 | passes [integer!] 22 | failures [integer!] 23 | ] 24 | qt-file: declare struct! [ 25 | tests [integer!] 26 | asserts [integer!] 27 | passes [integer!] 28 | failures [integer!] 29 | ] 30 | ;; group switches 31 | qt-group-name-not-printed: true 32 | qt-group?: false 33 | 34 | _qt-init-group: does [ 35 | 36 | qt-group-name-not-printed: true 37 | qt-group?: false 38 | qt-group-name: "" 39 | ] 40 | 41 | qt-init-run: func [] [ 42 | qt-run/tests: 0 43 | qt-run/asserts: 0 44 | qt-run/passes: 0 45 | qt-run/failures: 0 46 | _qt-init-group 47 | ] 48 | 49 | qt-init-file: func [] [ 50 | qt-file/tests: 0 51 | qt-file/asserts: 0 52 | qt-file/passes: 0 53 | qt-file/failures: 0 54 | _qt-init-group 55 | ] 56 | 57 | ***start-run***: func[ 58 | title [c-string!] 59 | ][ 60 | qt-init-run 61 | qt-run-name: title 62 | print ["***Starting*** " title lf lf] 63 | ] 64 | 65 | ~~~start-file~~~: func [ 66 | title [c-string!] 67 | ][ 68 | qt-init-file 69 | print ["~~~started test~~~ " title lf] 70 | qt-file-name: title 71 | qt-group?: false 72 | ] 73 | 74 | ===start-group===: func [ 75 | title [c-string!] 76 | ][ 77 | qt-group-name: title 78 | qt-group?: true 79 | ] 80 | 81 | --test--: func [ 82 | title [c-string!] 83 | ][ 84 | qt-test-name: title 85 | qt-file/tests: qt-file/tests + 1 86 | ] 87 | 88 | --assert: func [ 89 | assertion [logic!] 90 | ][ 91 | qt-file/asserts: qt-file/asserts + 1 92 | 93 | either assertion [ 94 | qt-file/passes: qt-file/passes + 1 95 | ][ 96 | qt-file/failures: qt-file/failures + 1 97 | if qt-group? [ 98 | if qt-group-name-not-printed [ 99 | print [lf "===group=== " qt-group-name lf] 100 | qt-group-name-not-printed: false 101 | ] 102 | ] 103 | print ["--test-- " qt-test-name " FAILED**************" lf] 104 | ] 105 | ] 106 | 107 | --assertf~=: func[ 108 | x [float!] 109 | y [float!] 110 | e [float!] 111 | /local 112 | diff [float!] 113 | e1 [float!] 114 | e2 [float!] 115 | ][ 116 | ;; calculate tolerance to use 117 | ;; as e * max (1, x, y) 118 | either x > 0.0 [ 119 | e1: x * e 120 | ][ 121 | e1: -1.0 * x * e 122 | ] 123 | if e > e1 [e1: e] 124 | either y > 0.0 [ 125 | e2: y * e 126 | ][ 127 | e2: -1.0 * y * e 128 | ] 129 | if e1 > e2 [e2: e1] 130 | 131 | ;; perform almost equal check 132 | either x > y [ 133 | diff: x - y 134 | ][ 135 | diff: y - x 136 | ] 137 | either diff > e2 [ 138 | --assert false 139 | ][ 140 | --assert true 141 | ] 142 | ] 143 | 144 | --assertf32~=: func[ 145 | x [float32!] 146 | y [float32!] 147 | e [float32!] 148 | /local 149 | diff [float32!] 150 | e1 [float32!] 151 | e2 [float32!] 152 | ][ 153 | ;; calculate tolerance to use 154 | ;; as e * max (1, x, y) 155 | either x > as float32! 0.0 [ 156 | e1: x * e 157 | ][ 158 | e1: as float32! -1.0 * x * e 159 | ] 160 | if e > e1 [e1: e] 161 | either y > as float32! 0.0 [ 162 | e2: y * e 163 | ][ 164 | e2: as float32! -1.0 * y * e 165 | ] 166 | if e1 > e2 [e2: e1] 167 | 168 | ;; perform almost equal check 169 | either x > y [ 170 | diff: x - y 171 | ][ 172 | diff: y - x 173 | ] 174 | either diff > e2 [ 175 | --assert false 176 | ][ 177 | --assert true 178 | ] 179 | ] 180 | 181 | 182 | ===end-group===: func [] [ 183 | _qt-init-group 184 | ] 185 | 186 | ~~~end-file~~~: func [] [ 187 | print ["~~~finished test~~~ " qt-file-name lf] 188 | qt-print-totals qt-file/tests 189 | qt-file/asserts 190 | qt-file/passes 191 | qt-file/failures 192 | print lf 193 | 194 | ;; update run totals 195 | qt-run/passes: qt-run/passes + qt-file/passes 196 | qt-run/asserts: qt-run/asserts + qt-file/asserts 197 | qt-run/failures: qt-run/failures + qt-file/failures 198 | qt-run/tests: qt-run/tests + qt-file/tests 199 | ] 200 | 201 | ***end-run***: func [][ 202 | print ["***Finished*** " qt-run-name lf] 203 | qt-print-totals qt-run/tests 204 | qt-run/asserts 205 | qt-run/passes 206 | qt-run/failures 207 | ] 208 | 209 | qt-print-totals: func [ 210 | tests [integer!] 211 | asserts [integer!] 212 | passes [integer!] 213 | failures [integer!] 214 | ][ 215 | print [" Number of Tests Performed: " tests lf] 216 | print [" Number of Assertions Performed: " asserts lf] 217 | print [" Number of Assertions Passed: " passes lf] 218 | print [" Number of Assertions Failed: " failures lf] 219 | if failures <> 0 [ 220 | print ["****************TEST FAILURES****************" lf] 221 | ] 222 | ] 223 | 224 | 225 | -------------------------------------------------------------------------------- /quick-test/quick-unit-test.r: -------------------------------------------------------------------------------- 1 | REBOL [ 2 | Title: "Red Bootstrap unit testing framework" 3 | Author: "Peter W A Wood" 4 | File: %quick-unit-test.r 5 | Version: 0.2.0 6 | Tabs: 4 7 | Rights: "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved." 8 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 9 | ] 10 | 11 | qut: make object! [ 12 | 13 | test-print: :print 14 | test-prin: :prin 15 | output: copy "" 16 | set 'print func[v][append output rejoin [v lf]] 17 | set 'prin func[v][append output reduce v] 18 | 19 | ;; text fields 20 | run-name: copy "" 21 | file-name: copy "" 22 | group-name: copy "" 23 | test-name: copy "" 24 | 25 | ;; counters 26 | data: make object! [ 27 | tests: 0 28 | asserts: 0 29 | passes: 0 30 | failures: 0 31 | ] 32 | run: make data [] 33 | file: make data [] 34 | 35 | ;; group switches 36 | group-name-not-prined: true 37 | group?: false 38 | 39 | init-group: does [ 40 | group-name-not-prined: true 41 | group?: false 42 | group-name: "" 43 | ] 44 | 45 | init-data: func [ 46 | data [object!] 47 | ][ 48 | data/tests: 0 49 | data/asserts: 0 50 | data/passes: 0 51 | data/failures: 0 52 | ] 53 | 54 | init-run: does [ 55 | init-data run 56 | init-group 57 | ] 58 | 59 | init-file: does [ 60 | init-data file 61 | init-group 62 | ] 63 | 64 | start-run: func[ 65 | title [string!] 66 | ][ 67 | init-run 68 | run-name: title 69 | test-prin ["***Starting*** " title lf lf] 70 | ] 71 | 72 | start-file: func [ 73 | title [string!] 74 | ][ 75 | init-file 76 | test-prin ["~~~started test~~~ " title lf] 77 | file-name: title 78 | group?: false 79 | ] 80 | 81 | start-group: func [ 82 | title [string!] 83 | ][ 84 | group-name: title 85 | group?: true 86 | ] 87 | 88 | start-test: func [ 89 | title [string!] 90 | ][ 91 | test-name: title 92 | file/tests: file/tests + 1 93 | output: copy "" 94 | ] 95 | 96 | assert: func [ 97 | assertion [logic!] 98 | ][ 99 | file/asserts: file/asserts + 1 100 | 101 | either assertion [ 102 | file/passes: file/passes + 1 103 | ][ 104 | file/failures: file/failures + 1 105 | if group? [ 106 | if group-name-not-prined [ 107 | test-prin [lf "===group=== " group-name lf] 108 | group-name-not-prined: false 109 | ] 110 | ] 111 | test-prin ["--test-- " test-name " FAILED**************" lf] 112 | ] 113 | ] 114 | 115 | assert-printed?: func [msg] [ 116 | assert found? find qut/output msg 117 | ] 118 | 119 | end-group: func [] [ 120 | init-group 121 | ] 122 | 123 | end-file: func [] [ 124 | test-prin ["~~~finished test~~~ " file-name lf] 125 | print-totals file 126 | test-prin lf 127 | 128 | ;; update run totals 129 | run/passes: run/passes + file/passes 130 | run/asserts: run/asserts + file/asserts 131 | run/failures: run/failures + file/failures 132 | run/tests: run/tests + file/tests 133 | ] 134 | 135 | end-run: func [][ 136 | test-prin ["***Finished*** " run-name lf] 137 | print-totals run 138 | set 'print :test-print 139 | set 'prin :test-print 140 | ] 141 | 142 | print-totals: func [ 143 | data [object!] 144 | ][ 145 | test-prin [" Number of Tests Performed: " data/tests lf] 146 | test-prin [" Number of Assertions Performed: " data/asserts lf] 147 | test-prin [" Number of Assertions Passed: " data/passes lf] 148 | test-prin [" Number of Assertions Failed: " data/failures lf] 149 | if data/failures <> 0 [ 150 | test-prin ["****************TEST FAILURES****************" lf] 151 | ] 152 | ] 153 | 154 | ;; create the test "dialect" 155 | set '***start-run*** :start-run 156 | set '~~~start-file~~~ :start-file 157 | set '===start-group=== :start-group 158 | set '--test-- :start-test 159 | set '--assert :assert 160 | set '--assert-printed? :assert-printed? 161 | set '===end-group=== :end-group 162 | set '~~~end-file~~~ :end-file 163 | set '***end-run*** :end-run 164 | 165 | ] 166 | -------------------------------------------------------------------------------- /quick-test/run-test.r: -------------------------------------------------------------------------------- 1 | REBOL [ 2 | Title: "Builds and Runs a single Red/System Tests" 3 | File: %run-test.r 4 | Author: "Peter W A Wood" 5 | Version: 0.10.0 6 | License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt" 7 | ] 8 | 9 | ;; include quick-test.r 10 | do %quick-test.r 11 | 12 | ;; set the base dir for the test source 13 | qt/tests-dir: system/script/path 14 | remove/part find/last qt/tests-dir "quick-test/" 11 15 | qt/tests-dir: what-dir 16 | 17 | print rejoin ["Quick-Test v" qt/version] 18 | print rejoin ["Running under REBOL " system/version] 19 | 20 | ;; get the name of the test file & any other args 21 | args: parse system/script/args " " 22 | src: last args 23 | if find system/script/args "--binary" [qt/binary-compiler?: true] 24 | all [ 25 | 2 < length? args 26 | src <> temp: select args "--binary" 27 | qt/bin-compiler: temp 28 | ] 29 | 30 | either any [ 31 | not src: to-file src 32 | all [ 33 | %.r <> suffix? src 34 | %.red <> suffix? src 35 | %.reds <> suffix? src 36 | ] 37 | ][ 38 | print "No valid test file supplied" 39 | ][ 40 | either any [ 41 | %.reds = suffix? src 42 | %.red = suffix? src 43 | ][ 44 | --compile-run-print src 45 | ][ 46 | 47 | either find read qt/tests-dir/:src "quick-unit-test.r" [ 48 | --run-unit-test src 49 | ][ 50 | ;; copy and run rebol script 51 | qt/run-script src 52 | ] 53 | ] 54 | ] 55 | 56 | prin "" 57 | -------------------------------------------------------------------------------- /quick-test/tests/overwrite-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Tests for overwrite function" 3 | Author: "Peter W A Wood" 4 | File: %overwrite-test.reds 5 | Tabs: 4 6 | Rights: copyright (c) 2011-2015 Peter W A Wood 7 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 8 | ] 9 | 10 | #include %../quick-test.reds 11 | #include %../overwrite.reds 12 | #include %../prin-int.reds 13 | 14 | qt-start-file "overwrite" 15 | 16 | ow-s1: "Hello, World" 17 | max-len: length? ow-s1 18 | ow-e1: "Hello, Peter" 19 | overwrite ow-s1 "Hello, Peter" max-len 20 | qt-assert "ow-1" ow-s1 = ow-e1 21 | 22 | ow-s2: "short" 23 | max-len: length? ow-s2 24 | ow-e2: "longe" 25 | overwrite ow-s2 "longer" max-len 26 | qt-assert "ow-2" ow-s2 = ow-e2 27 | qt-assert "ow-3" 5 = length? ow-s2 28 | 29 | ow-s3: "longer" 30 | max-len: length? ow-s3 31 | ow-e3: "short" 32 | overwrite ow-s3 "short" max-len 33 | qt-assert "ow-4" ow-s3 = ow-e3 34 | qt-assert "ow-5" 5 = length? ow-s3 35 | 36 | ow-s4: "longer" 37 | max-len: length? ow-s4 38 | ow-e4: "but no" 39 | overwrite ow-s4 "s" max-len 40 | overwrite ow-s4 "but not this long" max-len 41 | qt-assert "ow-6" ow-s4 = ow-e4 42 | qt-assert "ow-7" 6 = length? ow-s4 43 | 44 | qt-end-file 45 | 46 | -------------------------------------------------------------------------------- /quick-test/tests/qt-test.r: -------------------------------------------------------------------------------- 1 | REBOL [ 2 | Title: "Red/System quick testing framework unit tests" 3 | Author: "Peter W A Wood" 4 | File: %qt-test.r 5 | Tabs: 4 6 | Rights: "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved." 7 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 8 | ] 9 | 10 | do %../quick-test.r 11 | 12 | ~~~start-file~~~ "quick-test.r unit tests" 13 | 14 | ===start-group=== "UTF-16LE to UTF-8" 15 | 16 | --test-- "u16u8-1" 17 | --assert "^(CE)^(A7)" = qt/utf-16le-to-utf-8 "^(A7)^(03)" 18 | 19 | --test-- "u16u8-2" 20 | --assert "^(CE)^(B1)" = qt/utf-16le-to-utf-8 "^(B1)^(03)" 21 | 22 | --test-- "u16u8-3" 23 | --assert "^(E1)^(BF)^(96)" = qt/utf-16le-to-utf-8 "^(D6)^(1F)" 24 | print to binary! qt/utf-16le-to-utf-8 "^(D6)^(1F)" 25 | 26 | --test-- "u16u8-4" 27 | --assert "^(CE)^(B5)" = qt/utf-16le-to-utf-8 "^(B5)^(03)" 28 | 29 | 30 | ===end-group=== 31 | 32 | ~~~end-file~~~ 33 | 34 | -------------------------------------------------------------------------------- /quick-test/tests/qt-test.reds: -------------------------------------------------------------------------------- 1 | Red/System [ 2 | Title: "Red/System simple testing framework tests" 3 | Author: "Peter W A Wood" 4 | File: %qt-test.reds 5 | Tabs: 4 6 | Rights: "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved." 7 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 8 | ] 9 | 10 | #include %../quick-test.reds 11 | 12 | ***start-run*** "Test Run 1" 13 | 14 | ~~~start-file~~~ "First Test Set" 15 | 16 | ===start-group=== "My First Group" 17 | 18 | --test-- "Test 1" 19 | --assert (true) ;; pass 20 | 21 | --test-- "Test 2" 22 | --assert (true) ;; pass 23 | --assert (true) ;; pass 24 | 25 | --test-- "Test 3" 26 | --assert (false) ;; fail 27 | 28 | --test-- "Test 4" 29 | --assert 1 = 1 ;; pass 30 | 31 | --test-- "Test 5" 32 | --assert 1 = 2 ;; fail 33 | 34 | --test-- "Test 6" ;; a longer test 35 | step1: 1 36 | step2: 2 37 | step3: 3 38 | step4: step1 + step2 + step3 39 | --assert step4 = 6 ;;pass 40 | 41 | ===end-group=== 42 | 43 | ===start-group=== "My second group" 44 | 45 | --test-- "msg-1" 46 | --assert true 47 | 48 | --test-- "msg-2" 49 | --assert true 50 | 51 | ===end-group=== 52 | 53 | ===start-group=== "My third group" 54 | 55 | --test-- "mtg-1" 56 | --assert false 57 | 58 | --test-- "mtg-2" 59 | --assert true 60 | 61 | ===end-group=== 62 | 63 | ~~~end-file~~~ 64 | 65 | ~~~start-file~~~ "Second Test Set" 66 | 67 | --test-- "Test 7" 68 | --assert true 69 | 70 | --test-- "Test 8" 71 | --assert false 72 | 73 | ~~~end-file~~~ 74 | 75 | ***end-run*** 76 | 77 | -------------------------------------------------------------------------------- /run-test: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | clear 3 | RED="/usr/local/bin/red --cli" 4 | time ${RED} ./all-test.red 5 | 6 | --------------------------------------------------------------------------------