├── test.txt ├── tests.xlsx ├── .gitattributes ├── haxcel.hs ├── src ├── lib.rs ├── haskell.rs ├── exports.rs └── process.rs ├── .gitignore ├── Cargo.toml ├── LICENSE ├── launch.json ├── README.md └── test.hs /test.txt: -------------------------------------------------------------------------------- 1 | 2+2 2 | :q 3 | -------------------------------------------------------------------------------- /tests.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MarcusRainbow/Haxcel/HEAD/tests.xlsx -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /haxcel.hs: -------------------------------------------------------------------------------- 1 | hx_show :: Show a => Int -> [a] -> String 2 | hx_show _ [] = "" 3 | hx_show 0 _ = "..." 4 | hx_show _ [x] = show x 5 | hx_show n (x:xs) = show x ++ ", " ++ hx_show (n-1) xs 6 | 7 | hx_show :: Show a => Int -> a -> String 8 | hx_show _ = show x 9 | -------------------------------------------------------------------------------- /src/lib.rs: -------------------------------------------------------------------------------- 1 | pub mod exports; 2 | mod process; 3 | mod haskell; 4 | 5 | extern crate xladd; 6 | extern crate winapi; 7 | 8 | #[cfg(test)] 9 | mod tests { 10 | #[test] 11 | fn it_works() { 12 | assert_eq!(2 + 2, 4); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Generated by Cargo 2 | # will have compiled files and executables 3 | /target/ 4 | 5 | # Remove Cargo.lock from gitignore if creating an executable, leave it for libraries 6 | # More information here https://doc.rust-lang.org/cargo/guide/cargo-toml-vs-cargo-lock.html 7 | Cargo.lock 8 | 9 | # These are backup files generated by rustfmt 10 | **/*.rs.bk 11 | -------------------------------------------------------------------------------- /Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "haxcel" 3 | version = "0.1.0" 4 | authors = ["Marcus Rainbow"] 5 | license = "MIT" 6 | description = "Haxcel: Excel gateway to Haskell" 7 | documentation = "https://github.com/MarcusRainbow/Haxcel/README.md" 8 | repository = "https://github.com/MarcusRainbow/Haxcel" 9 | keywords = ["Excel", "Haskell"] 10 | categories = ["mathematics", "science"] 11 | 12 | [dependencies] 13 | winapi = { version = "0.3.5", features = [ 14 | "winuser", "libloaderapi", "debugapi", "processthreadsapi", "handleapi", 15 | "namedpipeapi", "winbase", "fileapi", "errhandlingapi", "wincon", 16 | ] } 17 | xladd = "0.1.2" 18 | #xladd = { path = "../xladd-master" } 19 | 20 | [lib] 21 | name = "haxcel" 22 | crate-type = ["cdylib"] -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Marcus Rainbow 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 | -------------------------------------------------------------------------------- /launch.json: -------------------------------------------------------------------------------- 1 | { 2 | // Use IntelliSense to learn about possible attributes. 3 | // Hover to view descriptions of existing attributes. 4 | // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 5 | "version": "0.2.0", 6 | "configurations": [ 7 | { 8 | "name": "Windbg" 9 | ,"type": "windbg" 10 | ,"request": "launch" 11 | ,"target": "C:\\Program Files\\Microsoft Office\\root\\Office16\\Excel.exe" 12 | ,"verbosity": "debug" 13 | ,"windbgpath": "C:/Program Files (x86)/Windows Kits/10/Debuggers/x64/dbgeng.dll" 14 | ,"workingDir": "${workspaceRoot}" 15 | ,"sources": [ 16 | "${workspaceRoot}/src" 17 | //,"%RUST_SRC_PATH%" 18 | ] 19 | }, 20 | { 21 | "name": "(Windows) Launch", 22 | "type": "cppvsdbg", 23 | "request": "launch", 24 | "program": "C:\\Program Files\\Microsoft Office\\root\\Office16\\Excel.exe", 25 | "args": [], 26 | "stopAtEntry": false, 27 | "cwd": "${workspaceFolder}", 28 | "environment": [], 29 | "externalConsole": false 30 | } 31 | ] 32 | } -------------------------------------------------------------------------------- /src/haskell.rs: -------------------------------------------------------------------------------- 1 | use xladd::variant::Variant; 2 | use process::{write_pipe, error_message, read_full_response, log}; 3 | 4 | pub fn load(name: &str) -> String { 5 | let command = format!(":l {}\n", name); 6 | execute_command(&command) 7 | } 8 | 9 | pub fn reload() -> String { 10 | execute_command(":r\n") 11 | } 12 | 13 | pub fn assign(name: &str, value: &str) -> String { 14 | let command = format!("{} = {}\n", name, value); 15 | let response = execute_command(&command); 16 | if response.is_empty() { 17 | // this is what we expect. Successful assignment does not output anything 18 | return name.to_string() 19 | } else { 20 | return response // error message or whatever -- just send it back to the user 21 | } 22 | } 23 | 24 | /// Returns a variant that contains the value as a string 25 | pub fn show(value: &str, dim: (usize, usize)) -> Variant { 26 | eval_show(value, dim, Variant::from_str) 27 | } 28 | 29 | /// Returns a variant that contains the value as a floating point 30 | /// number if possible. 31 | pub fn eval(value: &str, dim: (usize, usize)) -> Variant { 32 | eval_show(value, dim, |s| { 33 | if let Ok(value) = s.parse::() { 34 | Variant::from_float(value) 35 | } else { 36 | Variant::from_str(s) 37 | } 38 | }) 39 | } 40 | 41 | fn eval_show(value: &str, dim: (usize, usize), make_var: fn (&str) -> Variant) -> Variant { 42 | // we first assign the result of the expression to a temp variable 43 | // (maybe be a bit cleverer about the name, but it makes sense to 44 | // reuse the same name, so results get garbage collected). 45 | let temp = "hk_temp"; 46 | let command = format!("{} = {}\n", temp, value); 47 | let response = execute_command(&command); 48 | if ! response.is_empty() { 49 | // Successful assignment does not output anything. If there was anything there, send it as an error 50 | return Variant::from_str(&response) 51 | } 52 | 53 | // now take a peek at the type of the result 54 | if ! write_pipe(":t hk_temp\n") { 55 | return Variant::from_str("Error: Cannot ask Haskell the type") 56 | } 57 | let result_type; 58 | if let Some(result) = read_full_response() { 59 | if result.is_empty() { 60 | return Variant::from_str("Error: no type response from Haskell") 61 | } else { 62 | result_type = result.trim().to_string(); 63 | } 64 | } else { 65 | return Variant::from_str(&error_message("Error: Cannot read from Haskell")) 66 | } 67 | 68 | // The results here might be something like "hk_temp :: (Num a, Enum a) => [a]" 69 | // or hk_temp :: [Integer]. We can tell whether this is a list or list of lists 70 | // by popping ] characters off the end. 71 | let mut type_iter = result_type.chars().rev(); 72 | if type_iter.next().unwrap() == ']' { 73 | if type_iter.next().unwrap() == ']' { 74 | show_list_of_lists(temp, dim, make_var) 75 | } else { 76 | show_list(temp, dim, make_var) 77 | } 78 | } else { 79 | make_var(&execute_command(&format!("{}\n", temp))) 80 | } 81 | } 82 | 83 | fn show_list(var: &str, dim: (usize, usize), make_var: fn (&str) -> Variant) -> Variant { 84 | let cols = if dim.0 > 1 {dim.0} else {dim.1}; 85 | if cols == 0 { 86 | return Variant::from_str("Error: destination of formula has zero size") 87 | } 88 | let value = format!("take {} {}\n", cols, var); 89 | let list = execute_command(&value).trim().to_string(); 90 | let trimmed = trim_brackets(&list); 91 | 92 | let result_strings: Vec<&str> = trimmed.split(',').collect(); 93 | if result_strings.is_empty() { 94 | return Variant::missing() 95 | } 96 | 97 | let mut results = Vec::with_capacity(cols); 98 | for result in result_strings { 99 | results.push(make_var(result)); 100 | } 101 | 102 | return Variant::from_array(dim.0, dim.1, &results) 103 | } 104 | 105 | fn show_list_of_lists(var: &str, dim: (usize, usize), make_var: fn (&str) -> Variant) -> Variant { 106 | if dim.0 == 0 || dim.1 == 0 { 107 | return Variant::from_str("Error: destination of formula has zero size") 108 | } 109 | let value = format!("take {} (map (take {}) {})\n", dim.1, dim.0, var); 110 | let list = execute_command(&value).trim().to_string(); 111 | 112 | let result_strings: Vec<&str> = list.split(',').collect(); 113 | if result_strings.is_empty() { 114 | return Variant::missing() 115 | } 116 | 117 | let mut results = Vec::with_capacity(dim.0 * dim.1); 118 | for result in result_strings { 119 | results.push(make_var(trim_brackets(result))); 120 | } 121 | 122 | return Variant::from_array(dim.0, dim.1, &results) 123 | } 124 | 125 | fn trim_brackets(text: &str) -> &str { 126 | text.trim_start_matches('[').trim_end_matches(']') 127 | } 128 | 129 | pub fn execute_command(command: &str) -> String { 130 | if ! write_pipe(&command) { 131 | return error_message("Error: Cannot write to Haskell") 132 | } 133 | 134 | if let Some(result) = read_full_response() { 135 | return result 136 | } else { 137 | return error_message("Error: Cannot read from Haskell") 138 | } 139 | } 140 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haxcel 2 | 3 | An addin for running Haskell within Excel. 4 | 5 | ## Motivation 6 | 7 | In some senses, Excel is a functional language. Functions in cells generally do not have side-effects. Flow of control expressions such as IF are functions, as is everything else. However, some things are missing, and for these, an embedded genuinely functional language such as Haskell is helpful. Moreover, because Excel is itself partly functional, Haskell embeds in a really natural way, so you can easily use both Excel and Haskell functions together in the same sheet. 8 | 9 | * In Haxcel, functions are first-class objects, so you can create a function at runtime, store it in an Excel cell and pass it to other funtions. 10 | * In Haxcel, function calls are non-strict, which makes it possible to handle infinitely recursive functions and infinite lists. The functions are only evaluated to the extent that they fill the cells the user wants them to fill, and they are only evaluated when they are needed. 11 | * Haxcel allows you to load and compile Haskell modules, which opens the possibility of really high-performance computing in a spreadsheet. It also allows you to use Haskell libraries, for specialised tasks such as financial maths. 12 | * Haxcel optionally works with floating point numbers, which interface well with native Excel, or strings, which support Haskell types such as Integer (integers of unlimited size), Rational (exact representation of rational numbers), Complex etc. 13 | 14 | ## How it works 15 | 16 | GHCI is the command-line interpreter for Glasgow Haskell. From the command line you can execute Haskell code, control the Haskell environment and load/reload/unload modules. It is possible to assign values, functions and other data structures to labels, which can be used in future command line actions. 17 | 18 | This addin launches GHCI in a separate process, but controlling its stdin and stdout. This means that from within Excel, we can pass commands to Haskell, assigning and storing values, functions etc, which can then be used from other cells. In the unlikely event of Haskell crashing, it will not bring down Excel. Something I am working on is the ability to interrupt a slow-running or infinite Haskell function, so that Excel can continue and Haskell can be restarted. 19 | 20 | ## How to use it 21 | 22 | The key functions are hxAssign and hxShow. These are the equivalent in Haskell of expressions like "a = foo x" and "foo x". 23 | 24 | You need to be aware that Excel is itself a kind of functional language. Formulae in cells are first inspected to find any inter-cell dependencies, so that Excel can produce an acyclic graph, much like the AST in a functional language such as Haskell. 25 | 26 | Much like Haskell, expressions are not evaluated in left-right top-bottom order, but are evaluated non-strictly in the order specified by the dependency graph. 27 | 28 | What this means is that you have to be careful to get the inter-cell dependencies right. For example, if you want to use a variable you have assigned using hxAssign, you need to make sure that hxAssign cell is evaluated before the place you use the variable. To make this easier, methods like hxAssign take multiple parameters, so you can point at the cells that define the variables you use. If hxAssign succeeds, it writes the name of its assigned variable into the cell. 29 | 30 | ### hxAssign 31 | 32 | ```Excel 33 | =hxAssign("add_three_cells", "{} + {} + {}", A1, A2, A3) 34 | ``` 35 | 36 | hxAssign allows you to assign a name to a Haskell expression. The expression can be a number, string, list or a function -- anything that Haskell can assign a name to. The function is typically not evaluated unless it is marked as strict. Thus it is perfectly legal to write something like hxAssign("all_positive_integers", "[0..]"). This would take forever to execute as it stands, but non-strict evaluation means only as much of it is evaluated as is needed, when it is needed. 37 | 38 | You can use hxAssign to define functions, but the definition must be of the form label = expression. This means functions must be defined using lambda expressions. (We may add syntactic sugar methods to Haxcel to support function definition in prettier ways.) 39 | 40 | hxAssign returns the name (the first arg), in the case of success. This makes it easy to chain dependencies in a natural way. Note that Excel does not support cyclic dependency structures, as you could get with mutual recursion in Haskell. Mutual recursion can be set up in modules loaded into Excel, or by using string labels to break the dependecy cycles. In the case of error, hxAssign returns whatever error GHCI returned, as a string. 41 | 42 | The expression in hxAssign (the second arg) can contain embedded references to other variables, specified as "{}" as in Rust or Python. Eventually, we shall support format specifiers inside the braces, but not yet. These refer to the third and subsequent args, which means you can easily maintain the dependency structure of your Haskell definitions. 43 | 44 | ### hxExec 45 | 46 | ```Excel 47 | =hxExec("add_three_cells + {} + {} + {}", B1, B2, B3) 48 | ``` 49 | 50 | hxExec allows you to show inside Excel the result of a Haskell calculation. If the calculation simply returns a scalar or a string, this is the return value of hxExec and appears in the cell. If the calculation errored out, the error message appears in the cell. 51 | 52 | As with hxAssign, you can embed "{}" arguments in the expression. 53 | 54 | Where things get clever is if the expression returns a list or a list of lists. Haxcel finds out the number of cells you are trying to fill with the formula and executes "take" on the expression, so that only the minimum calculation is executed. 55 | 56 | For example, you could write: 57 | 58 | ```Excel 59 | =hxExec("ints_from 0 where ints_from n = [n..] : (ints_from (n+1))") 60 | ``` 61 | 62 | This expression returns an infinite list of infinite lists. If you invoke this expression as an array formula (Ctrl+Shift+Enter) in a 3x4 range of cells, it actually invokes: 63 | 64 | ```haskell 65 | hx_temp = ints_from 0 where ints_from n = [n..] : (ints_from (n+1)) 66 | :t hx_temp -- this finds that the expression is a list of lists 67 | take 4 (map (take 3) hx_temp) 68 | ``` 69 | 70 | This makes it harder to call something in Haskell that will never return. Though you still need to be careful -- some functions are very slow, and lists of lists of infinite lists need to be handled with care. 71 | 72 | ### Loading modules 73 | 74 | The functions for this are hxLoad and hxReload, which map to ":l" and ":r" in GHCI. The current directory is defined in your Excel settings, typically the "Documents" directory, so you probably want to supply a full path to the Haskell file to be loaded. 75 | 76 | Be careful with dependencies. The sample Excel file, test.xlsx, shows one way to ensure a module is loaded before the functions it defines are invoked. 77 | 78 | ### Some other functions 79 | 80 | | Function | Args | Behaviour | 81 | | ------------- |--------------- | ---------- | 82 | | hxShow | value, args... | Same as hxExec except it always writes strings | 83 | | hxRaw | command | Submits a command direct to GHCI and returns the response | 84 | | hxVersion | | Returns version information about Haxcel | 85 | | hxGHCIVersion | | Returns version information about GHCI | 86 | | hxLoggingOn | | Turns on logging to OutputDebugString (use DebugView to view it) | 87 | | hxLoggingOff | | Turns off logging | 88 | 89 | There are also functions for just writing to GHCI, or reading its stdout or stderr streams, but these should be treated with extreme care, as they can leave GHCI in an unstable state, or hang waiting for ever. 90 | 91 | ## Installing Haxcel 92 | 93 | Haxcel is written in Rust, and runs in Excel in Win64. (It may also run in 32bit Windows, but I have not tested that combination.) You therefore need a 64bit Windows machine with Microsoft Office. You also need a Win64 version of the Glasgow Haskell Compiler (GHC). Specifically, Haxcel uses GHCi in an interactive session, connecting with Windows Pipes. 94 | 95 | Install Rust for a Win64 environment (i.e. not Windows Subsystem Linux), including cargo. 96 | 97 | Haxcel depends on a number of other Rust projects (see the Cargo.toml file for details), but these should automatically install. You may need to install xladd manually, from this Git account. Again, this is a Rust project, with its own cargo file. 98 | 99 | Build Haxcel (and if necessary xladd) by running "cargo build install" from the directory containing Cargo.toml. The result of the build is a file Haxcel.dll. Where this ends up will depend on whether you build in debug or release, and what you call the directory containing Haxcel, but for example it may end up in "Haxcel\target\debug". 100 | 101 | One way to load it is to first load the sample spreadsheet, tests.xlsx. If you hit f9 to recalculate, you will see lots of error messages, as Haxcel is not loaded. Now load the dll by typing its full path into the File Open dialog. Excel will recognise that you are loading an unsigned Excel addin, and will warn you about the security risks. Override these and Excel will load Haxcel, and also start GHCi and connect Excel to GHCi using pipes. 102 | 103 | Now you can recalculate the spreadsheet, by selecting each cell and hitting f2 Enter, or by hitting f9 to recalculate the whole spreadsheet. You should see the correct calculation. 104 | -------------------------------------------------------------------------------- /src/exports.rs: -------------------------------------------------------------------------------- 1 | //! This file contains the functions exported to Excel. My recommendation is 2 | //! that any non-trivial logic within these functions is implemented 3 | //! elsewhere, to keep this module clean. 4 | //! 5 | //! We implement xlAutoOpen here, because it needs to register our exported 6 | //! functions. Other xlAuto methods are exported by xladd. 7 | 8 | use xladd::xlcall::xlGetName; 9 | use xladd::variant::Variant; 10 | use xladd::xlcall::{LPXLOPER12, xlfCaller}; 11 | use xladd::registrator::Reg; 12 | use xladd::entrypoint::excel12; 13 | use process::{start_ghci, ghci_version, raw_command, raw_read, 14 | raw_error, raw_write, raw_wait_read, raw_return, logging, always_log}; 15 | use haskell::{assign, show, eval, load, reload}; 16 | 17 | /// Shows version string. Note that in the Excel function wizard, this shows 18 | /// as requiring one unnamed parameter. This is a longstanding Excel bug. 19 | #[no_mangle] 20 | pub extern "stdcall" fn hxVersion() -> LPXLOPER12 { 21 | let result = Box::new(Variant::from_str("Haxcel: version 0.1.0")); 22 | Box::into_raw(result) as LPXLOPER12 23 | } 24 | 25 | #[no_mangle] 26 | pub extern "stdcall" fn hxGHCIVersion() -> LPXLOPER12 { 27 | let result = Box::new(Variant::from_str(&ghci_version())); 28 | Box::into_raw(result) as LPXLOPER12 29 | } 30 | 31 | #[no_mangle] 32 | pub extern "stdcall" fn hxRaw(xl_command: LPXLOPER12) -> LPXLOPER12 { 33 | let result; 34 | if let Some(command) = Variant::from_xloper(xl_command).as_string() { 35 | result = raw_command(&command); 36 | } else { 37 | result = "Error: command could not be interpreted as a string".to_string(); 38 | } 39 | 40 | let box_result = Box::new(Variant::from_str(&result)); 41 | Box::into_raw(box_result) as LPXLOPER12 42 | } 43 | 44 | #[no_mangle] 45 | pub extern "stdcall" fn hxRawRead() -> LPXLOPER12 { 46 | let result = raw_read(); 47 | let box_result = Box::new(Variant::from_str(&result)); 48 | Box::into_raw(box_result) as LPXLOPER12 49 | } 50 | 51 | #[no_mangle] 52 | pub extern "stdcall" fn hxRawError() -> LPXLOPER12 { 53 | let result = raw_error(); 54 | let box_result = Box::new(Variant::from_str(&result)); 55 | Box::into_raw(box_result) as LPXLOPER12 56 | } 57 | 58 | #[no_mangle] 59 | pub extern "stdcall" fn hxRawWaitRead() -> LPXLOPER12 { 60 | let result = raw_wait_read(); 61 | let box_result = Box::new(Variant::from_str(&result)); 62 | Box::into_raw(box_result) as LPXLOPER12 63 | } 64 | 65 | #[no_mangle] 66 | pub extern "stdcall" fn hxRawWrite(xl_command: LPXLOPER12) -> LPXLOPER12 { 67 | let result; 68 | if let Some(command) = Variant::from_xloper(xl_command).as_string() { 69 | result = raw_write(&command); 70 | } else { 71 | result = "Error: command could not be interpreted as a string".to_string(); 72 | } 73 | 74 | let box_result = Box::new(Variant::from_str(&result)); 75 | Box::into_raw(box_result) as LPXLOPER12 76 | } 77 | 78 | #[no_mangle] 79 | pub extern "stdcall" fn hxRawReturn() -> LPXLOPER12 { 80 | let result = raw_return(); 81 | let box_result = Box::new(Variant::from_str(&result)); 82 | Box::into_raw(box_result) as LPXLOPER12 83 | } 84 | 85 | #[no_mangle] 86 | pub extern "stdcall" fn hxLoggingOn() -> LPXLOPER12 { 87 | logging(true); 88 | let box_result = Box::new(Variant::from_str("Logging on")); 89 | Box::into_raw(box_result) as LPXLOPER12 90 | } 91 | 92 | #[no_mangle] 93 | pub extern "stdcall" fn hxLoggingOff() -> LPXLOPER12 { 94 | logging(false); 95 | let box_result = Box::new(Variant::from_str("Logging off")); 96 | Box::into_raw(box_result) as LPXLOPER12 97 | } 98 | 99 | #[no_mangle] 100 | pub extern "stdcall" fn hxAssign( 101 | xl_name: LPXLOPER12, 102 | xl_expr: LPXLOPER12, 103 | xl_arg0: LPXLOPER12, 104 | xl_arg1: LPXLOPER12, 105 | xl_arg2: LPXLOPER12, 106 | xl_arg3: LPXLOPER12, 107 | xl_arg4: LPXLOPER12, 108 | xl_arg5: LPXLOPER12) -> LPXLOPER12 { 109 | let result; 110 | if let (Some(name), Some(expr)) 111 | = (Variant::from_xloper(xl_name).as_string() 112 | , Variant::from_xloper(xl_expr).as_string()) { 113 | 114 | let expression = unpack_args(expr, &[xl_arg0, xl_arg1, xl_arg2, xl_arg3, xl_arg4, xl_arg5]); 115 | result = assign(&name, &expression); 116 | 117 | } else { 118 | result = "Error: args must be strings".to_string(); 119 | } 120 | 121 | let box_result = Box::new(Variant::from_str(&result)); 122 | Box::into_raw(box_result) as LPXLOPER12 123 | } 124 | 125 | #[no_mangle] 126 | pub extern "stdcall" fn hxLoad(xl_module: LPXLOPER12) -> LPXLOPER12 { 127 | let result; 128 | if let Some(module) = Variant::from_xloper(xl_module).as_string() { 129 | result = load(&module); 130 | 131 | } else { 132 | result = "Error: args must be strings".to_string(); 133 | } 134 | 135 | let box_result = Box::new(Variant::from_str(&result)); 136 | Box::into_raw(box_result) as LPXLOPER12 137 | } 138 | 139 | #[no_mangle] 140 | pub extern "stdcall" fn hxReload() -> LPXLOPER12 { 141 | let result = reload(); 142 | let box_result = Box::new(Variant::from_str(&result)); 143 | Box::into_raw(box_result) as LPXLOPER12 144 | } 145 | 146 | #[no_mangle] 147 | pub extern "stdcall" fn hxShow( 148 | xl_expr: LPXLOPER12, 149 | xl_arg0: LPXLOPER12, 150 | xl_arg1: LPXLOPER12, 151 | xl_arg2: LPXLOPER12, 152 | xl_arg3: LPXLOPER12, 153 | xl_arg4: LPXLOPER12, 154 | xl_arg5: LPXLOPER12) -> LPXLOPER12 { 155 | let result; 156 | if let Some(expr) = Variant::from_xloper(xl_expr).as_string() { 157 | let expression = unpack_args(expr, &[xl_arg0, xl_arg1, xl_arg2, xl_arg3, xl_arg4, xl_arg5]); 158 | 159 | // find out the dimensions of the array formula (if any) that invoked us 160 | let caller = excel12(xlfCaller, &mut []); 161 | result = show(&expression, caller.dim()); 162 | } else { 163 | result = Variant::from_str("Error: args must be strings"); 164 | } 165 | 166 | let box_result = Box::new(result); 167 | Box::into_raw(box_result) as LPXLOPER12 168 | } 169 | 170 | #[no_mangle] 171 | pub extern "stdcall" fn hxEval( 172 | xl_expr: LPXLOPER12, 173 | xl_arg0: LPXLOPER12, 174 | xl_arg1: LPXLOPER12, 175 | xl_arg2: LPXLOPER12, 176 | xl_arg3: LPXLOPER12, 177 | xl_arg4: LPXLOPER12, 178 | xl_arg5: LPXLOPER12) -> LPXLOPER12 { 179 | let result; 180 | if let Some(expr) = Variant::from_xloper(xl_expr).as_string() { 181 | let expression = unpack_args(expr, &[xl_arg0, xl_arg1, xl_arg2, xl_arg3, xl_arg4, xl_arg5]); 182 | 183 | // find out the dimensions of the array formula (if any) that invoked us 184 | let caller = excel12(xlfCaller, &mut []); 185 | result = eval(&expression, caller.dim()); 186 | } else { 187 | result = Variant::from_str("Error: args must be strings"); 188 | } 189 | 190 | let box_result = Box::new(result); 191 | Box::into_raw(box_result) as LPXLOPER12 192 | } 193 | 194 | fn unpack_args(expr : String, xl_args: &[LPXLOPER12]) -> String { 195 | let mut result = String::new(); 196 | let mut arg = 0; 197 | for section in expr.split("{}") { 198 | result += section; 199 | if arg < xl_args.len() { 200 | let mut variant : Variant = Variant::from_xloper(xl_args[arg]); 201 | // horrible code until we push is_missing method into xladd 202 | if variant.as_mut_xloper().xltype & 0x0080 != 0x0080 { 203 | result += &variant.to_string(); 204 | } 205 | arg += 1; 206 | } 207 | } 208 | return result; 209 | } 210 | 211 | #[no_mangle] 212 | pub extern "stdcall" fn xlAutoOpen() -> i32 { 213 | 214 | // start the process hosting Haskell 215 | start_ghci(); 216 | 217 | // register all the functions we are exporting to Excel 218 | let r = Reg::new(); 219 | r.add("hxVersion", "Q", "", "Haxcel", "Displays addin version number as text.", &[]); 220 | r.add("hxGHCIVersion", "Q", "", "Haxcel", "Displays GHCI version number as text.", &[]); 221 | r.add("hxRaw", "QQ", "Command", "Haxcel", "Submits raw text into GHCI and returns the result", &[]); 222 | r.add("hxRawRead", "Q", "", "Haxcel", "Returns any raw text that is ready from GHCI", &[]); 223 | r.add("hxRawError", "Q", "", "Haxcel", "Returns any raw error text that is ready from GHCI", &[]); 224 | r.add("hxRawWrite", "QQ", "Command", "Haxcel", "Submits raw text into GHCI and returns the result", &[]); 225 | r.add("hxRawReturn", "Q", "", "Haxcel", "Submits a raw carriage return into GHCI", &[]); 226 | r.add("hxRawWaitRead", "Q", "", "Haxcel", "Waits for then returns raw text from GHCI", &[]); 227 | r.add("hxLoggingOn", "Q", "", "Haxcel", "Turns on logging", &[]); 228 | r.add("hxLoggingOff", "Q", "", "Haxcel", "Turns off logging", &[]); 229 | r.add("hxLoad", "QQ", "", "Haxcel", "Loads a Haskell module", &[]); 230 | r.add("hxReload", "Q", "", "Haxcel", "Reloads all Haskell modules and clears all variables", &[]); 231 | r.add("hxAssign", "QQQQQQQQQ", "Name, Expression, Arg, Arg, Arg, Arg, Arg", "Haxcel", "Gets Haskell to assign the variable, then returns its name", &[]); 232 | r.add("hxEval", "QQQQQQQQ", "Expression, Arg, Arg, Arg, Arg, Arg", "Haxcel", "Evaluates a Haskell expression and writes it, numerically if possible, to the given cells", &[]); 233 | r.add("hxShow", "QQQQQQQQ", "Expression, Arg, Arg, Arg, Arg, Arg", "Haxcel", "Evaluates a Haskell expression and writes it as strings to the given cells", &[]); 234 | 235 | 1 236 | } 237 | 238 | -------------------------------------------------------------------------------- /src/process.rs: -------------------------------------------------------------------------------- 1 | use winapi::um::fileapi::{WriteFile, ReadFile}; 2 | use winapi::shared::minwindef::{BOOL, DWORD, LPCVOID, LPDWORD, LPVOID}; 3 | use winapi::um::processthreadsapi::{CreateProcessA, STARTUPINFOA, PROCESS_INFORMATION}; 4 | use winapi::um::handleapi::{CloseHandle, SetHandleInformation}; 5 | use winapi::um::namedpipeapi::{CreatePipe, PeekNamedPipe}; 6 | use winapi::um::wincon::GenerateConsoleCtrlEvent; 7 | // use winapi::um::winbase::handle_flag_inherit; 8 | use winapi::um::winbase::STARTF_USESTDHANDLES; 9 | use winapi::um::minwinbase::{SECURITY_ATTRIBUTES, LPOVERLAPPED}; 10 | use winapi::shared::ntdef::{NULL, TRUE}; 11 | use winapi::um::debugapi::OutputDebugStringA; 12 | use winapi::um::errhandlingapi::GetLastError; 13 | use winapi::um::winnt::HANDLE; 14 | use std::ffi::CString; 15 | use std::{mem, ptr, thread, time}; 16 | 17 | static mut GHCI_STDIN : HANDLE = NULL; 18 | static mut GHCI_STDOUT : HANDLE = NULL; 19 | static mut GHCI_STDERR : HANDLE = NULL; 20 | static mut GHCI_INITIAL_RESPONSE : Option = None; 21 | static mut LOGGING : bool = true; 22 | 23 | pub fn start_ghci() { 24 | 25 | unsafe { 26 | 27 | // Rather remarkable that the Windows TRUE definition is not of type BOOL 28 | let ok = TRUE as BOOL; 29 | 30 | // Set the bInheritHandle flag so pipe handles are inherited. 31 | let mut sa_attr = SECURITY_ATTRIBUTES { 32 | nLength : mem::size_of::() as DWORD, 33 | lpSecurityDescriptor : NULL, 34 | bInheritHandle: ok 35 | }; 36 | 37 | let mut child_stdin : HANDLE = NULL; 38 | let mut child_stdout : HANDLE = NULL; 39 | let mut child_stderr : HANDLE = NULL; 40 | 41 | // Create a pipe for the child process's STDIN. 42 | if CreatePipe(&mut child_stdin, &mut GHCI_STDIN, &mut sa_attr, 0) != ok { 43 | error_exit("Stdin CreatePipe") 44 | } 45 | 46 | // Ensure the write handle to the pipe for STDIN is not inherited. 47 | let handle_flag_inherit = 1 as DWORD; // cannot find the real definition of this 48 | if SetHandleInformation(GHCI_STDIN, handle_flag_inherit, 0) != ok { 49 | error_exit("Stdin SetHandleInformation") 50 | } 51 | 52 | // Create a pipe for the child process's STDOUT. 53 | if CreatePipe(&mut GHCI_STDOUT, &mut child_stdout, &mut sa_attr, 0) != ok { 54 | error_exit("StdoutRd CreatePipe") 55 | } 56 | 57 | // Ensure the read handle to the pipe for STDOUT is not inherited. 58 | if SetHandleInformation(GHCI_STDOUT, handle_flag_inherit, 0) != ok { 59 | error_exit("Stdout SetHandleInformation") 60 | } 61 | 62 | // Create a pipe for the child process's STDERR. 63 | if CreatePipe(&mut GHCI_STDERR, &mut child_stderr, &mut sa_attr, 0) != ok { 64 | error_exit("StderrRd CreatePipe") 65 | } 66 | 67 | // Ensure the read handle to the pipe for STDERR is not inherited. 68 | if SetHandleInformation(GHCI_STDERR, handle_flag_inherit, 0) != ok { 69 | error_exit("Stderr SetHandleInformation") 70 | } 71 | 72 | let reserved: *mut i8 = ptr::null_mut(); 73 | let ureserved: *mut u8 = ptr::null_mut(); 74 | 75 | // Set up the startup info to specify the three handles for the child to inherit 76 | let mut startup_info = STARTUPINFOA { 77 | cb : mem::size_of::() as DWORD, 78 | lpReserved : reserved, 79 | lpDesktop : reserved, 80 | lpTitle: reserved, 81 | dwX: 0, 82 | dwY: 0, 83 | dwXSize: 0, 84 | dwYSize: 0, 85 | dwXCountChars: 0, 86 | dwYCountChars: 0, 87 | dwFillAttribute: 0, 88 | dwFlags: STARTF_USESTDHANDLES, 89 | wShowWindow: 0, 90 | cbReserved2: 0, 91 | lpReserved2: ureserved, 92 | hStdInput : child_stdin, 93 | hStdOutput : child_stdout, 94 | hStdError : child_stderr 95 | }; 96 | 97 | let mut process_info = PROCESS_INFORMATION { 98 | hProcess : NULL, 99 | hThread : NULL, 100 | dwProcessId : 0, 101 | dwThreadId : 0 102 | }; 103 | 104 | let no_str: *mut i8 = ptr::null_mut(); 105 | let no_sec: *mut SECURITY_ATTRIBUTES = ptr::null_mut(); 106 | 107 | // CString is good at giving us a C-style string, but it must be 108 | // const. Unfortunately we must therefore painstakingly copy its buffer. 109 | let ghci = CString::new("GHCI").unwrap(); 110 | let bytes = ghci.as_bytes(); 111 | let mut buffer = Vec::::with_capacity(bytes.len() + 1); 112 | for i in bytes { 113 | buffer.push((*i) as i8); 114 | } 115 | buffer.push(0); 116 | 117 | if CreateProcessA( 118 | no_str, // lpApplicationName: LPCSTR, 119 | buffer.as_mut_ptr(), // lpCommandLine: LPSTR, 120 | no_sec, // lpProcessAttributes: LPSECURITY_ATTRIBUTES, 121 | no_sec, // lpThreadAttributes: LPSECURITY_ATTRIBUTES, 122 | TRUE as BOOL, // bInheritHandles: BOOL, 123 | 0x08000000, // dwCreationFlags: DWORD, 124 | NULL, // lpEnvironment: LPVOID, 125 | no_str, // lpCurrentDirectory: LPCSTR, 126 | &mut startup_info, // lpstartup_info: LPstartup_infoA, 127 | &mut process_info) != ok { // lpprocess_information: LPPROCESS_INFORMATION) 128 | error_exit("Failed to create child process") 129 | } 130 | 131 | CloseHandle(process_info.hProcess); 132 | CloseHandle(process_info.hThread); 133 | CloseHandle(child_stdin); 134 | CloseHandle(child_stdout); 135 | CloseHandle(child_stderr); 136 | 137 | // pull as much as we can from GHCI. This should be just version info 138 | // that GHCI outputs at startup. 139 | GHCI_INITIAL_RESPONSE = read_full_response_with_timeout(1000); 140 | } 141 | } 142 | 143 | pub fn ghci_version() -> String { 144 | let ver = unsafe { GHCI_INITIAL_RESPONSE.clone() }; 145 | ver.unwrap_or_default() 146 | } 147 | 148 | fn stdout_pipe() -> HANDLE { 149 | unsafe { GHCI_STDOUT } 150 | } 151 | 152 | fn stderr_pipe() -> HANDLE { 153 | unsafe { GHCI_STDERR } 154 | } 155 | 156 | fn stdin_pipe() -> HANDLE { 157 | unsafe { GHCI_STDIN } 158 | } 159 | 160 | fn error_exit(message: &str) { 161 | let cstr = CString::new(error_message(message)).unwrap(); 162 | unsafe { OutputDebugStringA(cstr.as_ptr()) }; 163 | } 164 | 165 | pub fn logging(on: bool) { 166 | unsafe { LOGGING = on }; 167 | if on { 168 | log("Turning logging on"); 169 | } else { 170 | log("Turning logging off") 171 | } 172 | } 173 | 174 | pub fn log(message: &str) { 175 | if unsafe { LOGGING } { 176 | always_log(message); 177 | } 178 | } 179 | 180 | pub fn always_log(message: &str) { 181 | let cstr = CString::new(message).unwrap(); 182 | unsafe { OutputDebugStringA(cstr.as_ptr()) }; 183 | } 184 | 185 | pub fn error_message(message: &str) -> String { 186 | let last_error = unsafe { GetLastError() }; 187 | format!("{}: {}", message, last_error) 188 | } 189 | 190 | pub fn raw_command(command: &str) -> String { 191 | 192 | // read whatever was previously in the GHCI stdout pipe 193 | if let Some(prev) = read_pipe_nonblocking(stdout_pipe()) { 194 | log(&prev); 195 | } else { 196 | return error_message("Error: Cannot read from GHCI pipe") 197 | } 198 | 199 | // write the command into the GHCI stdin pipe, followed by a carriage return 200 | if ! write_pipe(command) || ! write_pipe("\n") { 201 | return error_message("Error: Cannot write to GHCI pipe") 202 | } 203 | 204 | if let Some(result) = read_full_response() { 205 | return result 206 | } else { 207 | return error_message("Error: Cannot read from GHCI pipe") 208 | } 209 | } 210 | 211 | pub fn read_full_response() -> Option { 212 | read_full_response_with_timeout(0) 213 | } 214 | 215 | pub fn read_full_response_with_timeout(timeout_millis : i64) -> Option { 216 | // wait a short time for GHCI to respond, then longer periods 217 | let short_wait = time::Duration::from_millis(10); 218 | let long_wait = time::Duration::from_millis(200); 219 | let timeout_delta = if timeout_millis > 0 { 200 } else { 0 }; 220 | let mut timeout = timeout_millis; 221 | thread::sleep(short_wait); 222 | 223 | let mut result = String::new(); 224 | loop { 225 | if let Some(response) = read_pipe_nonblocking(stdout_pipe()) { 226 | log(&format!("read: {}", response)); 227 | 228 | if response.ends_with("> ") { 229 | if let Some(pos) = response.rfind("\n") { 230 | // if there is a response followed by a prompt, return the response 231 | result += &response[..pos].to_string() 232 | } 233 | // we have seen a prompt, so ok to exit the loop 234 | break; 235 | } else if timeout >= 0 { 236 | // if there is no prompt, then keep waiting 237 | result += &response; 238 | thread::sleep(long_wait); 239 | timeout -= timeout_delta; 240 | } else { 241 | // timed out. We don't want to just return anyway. We need to get 242 | // the GHCI process back to its command prompt somehow. 243 | // TODO: we cannot simply send a SIGINT like this. See https://social.msdn.microsoft.com/Forums/en-US/dc9586ab-1ee8-41aa-a775-cf4828ac1239/how-to-send-ctrlc-signal-to-detached-commandline-process?forum=windowsgeneraldevelopmentissues 244 | if unsafe { GenerateConsoleCtrlEvent(0, 0) } == 0 { 245 | always_log(&error_message("Error: Unable to send Ctrl+C after timeout")); 246 | return None 247 | } 248 | timeout = timeout_millis; 249 | } 250 | } 251 | } 252 | 253 | // We have seen the command prompt. Check whether there was 254 | // anything in stderr, and if so add it to whatever was in stdout 255 | // first see if there is anything in stderr 256 | if let Some(err_response) = read_pipe_nonblocking(stderr_pipe()) { 257 | log(&format!("stderr: {}", err_response)); 258 | result += &err_response; 259 | } 260 | 261 | return Some(result) 262 | } 263 | 264 | pub fn raw_write(message: &str) -> String { 265 | // write the command into the GHCI stdin pipe 266 | if ! write_pipe(message) { 267 | return error_message("Error: Cannot write to GHCI pipe") 268 | } 269 | return "OK".to_string() 270 | } 271 | 272 | pub fn raw_return() -> String { 273 | // write the command into the GHCI stdin pipe 274 | if ! write_pipe("\n") { 275 | return error_message("Error: Cannot write to GHCI pipe") 276 | } 277 | return "OK".to_string() 278 | } 279 | 280 | pub fn raw_wait_read() -> String { 281 | if let Some(response) = read_pipe(stdout_pipe()) { 282 | log(&format!("wait then read: {}", response)); 283 | return response; 284 | } else { 285 | return error_message("Error: Cannot read from GHCI pipe") 286 | } 287 | } 288 | 289 | pub fn raw_read() -> String { 290 | if let Some(response) = read_pipe_nonblocking(stdout_pipe()) { 291 | log(&format!("read: {}", response)); 292 | return response; 293 | } else { 294 | return error_message("Error: Cannot read from GHCI pipe") 295 | } 296 | } 297 | 298 | pub fn raw_error() -> String { 299 | if let Some(response) = read_pipe_nonblocking(stderr_pipe()) { 300 | log(&format!("error: {}", response)); 301 | return response; 302 | } else { 303 | return error_message("Error: Cannot read from GHCI stderr pipe") 304 | } 305 | } 306 | 307 | pub fn write_pipe(message: &str) -> bool { 308 | log(&format!("write: {}", message)); 309 | let buffer = CString::new(message).unwrap(); 310 | let raw_buffer = buffer.as_bytes(); 311 | return unsafe { WriteFile( 312 | stdin_pipe(), 313 | raw_buffer.as_ptr() as LPCVOID, 314 | raw_buffer.len() as DWORD, 315 | NULL as LPDWORD, 316 | NULL as LPOVERLAPPED) == TRUE as BOOL } 317 | } 318 | 319 | fn read_pipe(pipe: HANDLE) -> Option { 320 | let buffer_max = 1000; 321 | let mut read_buffer = Vec::::new(); 322 | let mut bytes_read : DWORD = 0; 323 | read_buffer.resize(buffer_max, 0); 324 | if unsafe { ReadFile( 325 | pipe, 326 | read_buffer.as_mut_ptr() as LPVOID, 327 | buffer_max as DWORD, 328 | &mut bytes_read, 329 | NULL as LPOVERLAPPED) != TRUE as BOOL } { 330 | return None; 331 | } 332 | 333 | let cstr_result = unsafe { CString::from_vec_unchecked(read_buffer) }; 334 | return Some(cstr_result.into_string().unwrap()); 335 | } 336 | 337 | fn read_pipe_nonblocking(pipe: HANDLE) -> Option { 338 | 339 | // do nothing if there is nothing in the pipe. Just return None. 340 | let mut bytes_avail : DWORD = 0; 341 | if unsafe { PeekNamedPipe( 342 | pipe, 343 | NULL, 344 | 0, 345 | NULL as LPDWORD, 346 | &mut bytes_avail, 347 | NULL as LPDWORD) != TRUE as BOOL } { 348 | always_log(&error_message("Error: PeekNamedPipe failed")); 349 | return None; 350 | } 351 | 352 | if bytes_avail == 0 { 353 | return Some("".to_string()); 354 | } 355 | 356 | let buffer_max = bytes_avail as usize; 357 | let mut read_buffer = Vec::::new(); 358 | let mut bytes_read : DWORD = 0; 359 | read_buffer.resize(buffer_max, 0); 360 | if unsafe { ReadFile( 361 | pipe, 362 | read_buffer.as_mut_ptr() as LPVOID, 363 | buffer_max as DWORD, 364 | &mut bytes_read, 365 | NULL as LPOVERLAPPED) != TRUE as BOOL } { 366 | always_log(&error_message("Error: ReadFile failed")); 367 | return None; 368 | } 369 | 370 | let cstr_result = unsafe { CString::from_vec_unchecked(read_buffer) }; 371 | return Some(cstr_result.into_string().unwrap()); 372 | } 373 | -------------------------------------------------------------------------------- /test.hs: -------------------------------------------------------------------------------- 1 | -- sayHello :: String -> IO () 2 | -- sayHello x = putStrLn ("Hello, " ++ x ++ "!") 3 | 4 | removeFst :: Eq a => a -> [a] -> [a] 5 | removeFst c [] = [] 6 | removeFst c (x:xs) 7 | | x == c = xs 8 | | otherwise = x:removeFst c xs 9 | 10 | count :: Char -> String -> Int 11 | count c [] = 0 12 | count c (x:xs) 13 | | x == c = 1 + count c xs 14 | | otherwise = count c xs 15 | 16 | blowup :: String -> String 17 | blowup = blowup_from 1 18 | 19 | blowup_from :: Int -> String -> String 20 | blowup_from count [] = [] 21 | blowup_from count (x:xs) = rep count x ++ blowup_from (count + 1) xs 22 | 23 | rep :: Int -> Char -> String 24 | rep count x 25 | | count < 0 = error "cannot repeat fewer than zero times" 26 | | count == 0 = [] 27 | | otherwise = x : rep (count - 1) x 28 | 29 | srtStrings :: [String] -> [String] 30 | srtStrings [] = [] 31 | srtStrings xs = m : (srtStrings (removeFst m xs)) where m = mnmString xs 32 | 33 | mnmString :: [String] -> String 34 | mnmString [] = error "empty list" 35 | mnmString [x] = x 36 | mnmString (x:xs) = min x (mnmString xs) 37 | 38 | prefix :: String -> String -> Bool 39 | prefix [] ys = True 40 | prefix (x:xs) [] = False 41 | prefix (x:xs) (y:ys) = (x==y) && prefix xs ys 42 | 43 | substring :: String -> String -> Bool 44 | substring xs ys | prefix xs ys = True 45 | substring xs (y:ys) | substring xs ys = True 46 | substring _ _ = False 47 | 48 | lengths :: [[a]] -> [Int] 49 | lengths xs = map length xs 50 | 51 | sumLengths :: [[a]] -> Int 52 | sumLengths xs = sum (lengths xs) 53 | 54 | ldp :: Integer -> Integer 55 | ldp = ldpf primes1 56 | 57 | ldpf :: [Integer] -> Integer -> Integer 58 | ldpf (p:ps) n 59 | | rem n p == 0 = p 60 | | p^2 > n = n 61 | | otherwise = ldpf ps n 62 | 63 | primes1 :: [Integer] 64 | primes1 = 2 : filter prime [3..] 65 | 66 | prime :: Integer -> Bool 67 | prime n 68 | | n <= 0 = error "not a positive integer" 69 | | n == 1 = False 70 | | otherwise = ldp n == n 71 | 72 | sieve :: [Integer] -> [Integer] 73 | sieve (0 : xs) = sieve xs 74 | sieve (n : xs) = n : sieve (mark xs 1 n) 75 | where 76 | mark :: [Integer] -> Integer -> Integer -> [Integer] 77 | mark (y:ys) k m 78 | | k == m = 0 : (mark ys 1 m) 79 | | otherwise = y : (mark ys (k+1) m) 80 | 81 | primes2 :: [Integer] 82 | primes2 = sieve [2..] 83 | 84 | oddsFrom3 :: [Integer] 85 | oddsFrom3 = 3 : map (+2) oddsFrom3 86 | 87 | primes3 :: [Integer] 88 | primes3 = 2 : oddsFrom3 89 | 90 | running_product :: Num a => a -> [a] -> [a] 91 | running_product _ [] = [] 92 | running_product p (x:xs) = prod : running_product prod xs 93 | where prod = p * x 94 | 95 | prime_prod_plus_one :: [Integer] 96 | prime_prod_plus_one = map (+1) (running_product 1 primes1) 97 | 98 | non_prime_prod_plus_one :: [Integer] 99 | non_prime_prod_plus_one = filter (not . prime) prime_prod_plus_one 100 | 101 | pdivisors :: Integral a => a -> [a] 102 | pdivisors n = [ d | d <- [1..(n-1)], rem n d == 0] 103 | 104 | prime_pairs :: [(Integer, Integer)] 105 | prime_pairs = pairs primes1 106 | where pairs (p1:p2:ps) | p2 == p1 + 2 = (p1, p2) : pairs (p2:ps) 107 | | otherwise = pairs (p2:ps) 108 | 109 | 110 | reverse' :: [a] -> [a] 111 | reverse' [] = [] 112 | reverse' (x:xs) = reverse' xs ++ [x] 113 | 114 | splitList :: [a] -> [([a], [a])] 115 | splitList [] = [] 116 | splitList (x:xs) = splitPrefix [x] xs 117 | 118 | splitPrefix :: [a] -> [a] -> [([a], [a])] 119 | splitPrefix p [] = [] 120 | splitPrefix p (x:xs) = (p, x:xs) : splitPrefix (p++[x]) xs 121 | 122 | diff :: Eq a => [a] -> [a] -> [a] 123 | diff [] y = [] 124 | diff (x:xs) y 125 | | x `elem` y = diff xs y 126 | | otherwise = x : diff xs y 127 | 128 | addElem :: a -> [[a]] -> [[a]] 129 | addElem x = map (x:) 130 | 131 | powerList :: [a] -> [[a]] 132 | powerList [] = [[]] 133 | powerList (x:xs) = (powerList xs) ++ addElem x (powerList xs) 134 | 135 | data S = Void deriving (Eq, Show) 136 | empty :: [S] 137 | empty = [] 138 | 139 | genIntersect :: Eq a => [[a]] -> [a] 140 | genIntersect [] = undefined 141 | genIntersect [x] = x 142 | genIntersect (x:y:xs) = genIntersect ((intersect x y):xs) 143 | 144 | intersect :: Eq a => [a] -> [a] -> [a] 145 | intersect [] y = [] 146 | intersect (x:xs) y 147 | | elem x y = x : intersect xs y 148 | | otherwise = intersect xs y 149 | 150 | genUnion :: Eq a => [[a]] -> [a] 151 | genUnion [] = [] 152 | genUnion [x] = x 153 | genUnion (x:y:xs) = genUnion ((union x y):xs) 154 | 155 | union :: Eq a => [a] -> [a] -> [a] 156 | union [] y = y 157 | union (x:xs) y 158 | | x `elem` y = union xs y 159 | | otherwise = x : union xs y 160 | 161 | stirling :: (Eq a, Num a) => a -> a -> a 162 | stirling n k 163 | | n == k = 1 164 | | k == 1 = 1 165 | | otherwise = k * stirling (n - 1) k + stirling (n - 1) (k - 1) 166 | 167 | bell :: (Num a, Enum a, Eq a) => a -> a 168 | bell n = sum [stirling n k | k <- [1..n]] 169 | 170 | listPartition :: Eq a => [a] -> [[a]] -> Bool 171 | listPartition xs xss = 172 | not (any null xss) && matchConcat xs xss && areDisjoint xss 173 | 174 | matchConcat :: Eq a => [a] -> [[a]] -> Bool 175 | matchConcat [] [] = True 176 | matchConcat [] yss = False 177 | matchConcat xs [] = False 178 | matchConcat xs (ys:yss) 179 | | containsAll xs ys = matchConcat (deleteAll ys xs) yss 180 | | otherwise = False 181 | 182 | containsAll :: Eq a => [a] -> [a] -> Bool 183 | containsAll xs [] = True 184 | containsAll xs (y:ys) 185 | | y `elem` xs = containsAll (delete y xs) ys 186 | | otherwise = False 187 | 188 | delete :: Eq a => a -> [a] -> [a] 189 | delete x [] = [] 190 | delete x (y:ys) 191 | | x == y = ys 192 | | otherwise = y : delete x ys 193 | 194 | deleteAll :: Eq a => [a] -> [a] -> [a] 195 | deleteAll [] ys = ys 196 | deleteAll (x:xs) ys = deleteAll xs (delete x ys) 197 | 198 | areDisjoint :: Eq a => [[a]] -> Bool 199 | areDisjoint [] = True 200 | areDisjoint (xs:xss) = any (disjoint xs) xss 201 | 202 | disjoint :: Eq a => [a] -> [a] -> Bool 203 | disjoint [] ys = True 204 | disjoint (x:xs) ys = not (elem x ys) && disjoint xs ys 205 | 206 | -- newtype Set a = Set [a] deriving (Eq, Ord) 207 | 208 | -- type Rel a = Set(a, a) 209 | 210 | listpart2equiv ::Ord a => [a] -> [[a]] -> [(a, a)] 211 | listpart2equiv _ [] = [] 212 | listpart2equiv dom (xs:xss) = (part2equiv xs) ++ listpart2equiv dom xss 213 | 214 | -- Creates an equivalence relation from a partition. Creates a 215 | -- set of all possible pairs from the given set. 216 | part2equiv :: [a] -> [(a, a)] 217 | part2equiv [] = [] 218 | part2equiv (x:xs) = (allPairs x xs) ++ part2equiv xs 219 | where 220 | allPairs x [] = [(x, x)] 221 | allPairs x (y:ys) = (x, y) : allPairs x ys 222 | 223 | equiv2listpart :: Ord a => [a] -> [(a, a)] -> [[a]] 224 | equiv2listpart _ [] = [] 225 | equiv2listpart dom ((x,y):xs) = mergePart x y (equiv2listpart dom xs) 226 | 227 | mergePart :: Ord a => a -> a -> [[a]] -> [[a]] 228 | mergePart x y xss = 229 | let 230 | xi = whereIs x xss 231 | yi = whereIs y xss 232 | in if xi < 0 && yi < 0 then (if x == y then [x] else [x, y]) : xss 233 | else if xi == yi then xss 234 | else if xi < 0 then insertAt yi x xss 235 | else if yi < 0 then insertAt xi y xss 236 | else mergeParts xi yi xss 237 | 238 | whereIs :: Eq a => a -> [[a]] -> Int 239 | whereIs x xss = whereHelper 0 x xss 240 | where 241 | whereHelper :: Eq a => Int -> a -> [[a]] -> Int 242 | whereHelper n x [] = -1 243 | whereHelper n x (ys:yss) 244 | | x `elem` ys = n 245 | | otherwise = whereHelper (n+1) x yss 246 | 247 | insertAt :: Int -> a -> [[a]] -> [[a]] 248 | insertAt i x (ys:yss) 249 | | i == 0 = (x:ys):yss 250 | | otherwise = ys : insertAt (i-1) x yss 251 | 252 | mergeParts :: Int -> Int -> [[a]] -> [[a]] 253 | mergeParts i j [] = error "cannot merge parts that do not exist" 254 | mergeParts i j xss'@(xs:xss) 255 | | i == j = xss' 256 | | i > j = mergeParts j i xss' 257 | | i == 0 = insertAll xs (j-1) xss 258 | | otherwise = mergeParts (i-1) (j-1) xss 259 | 260 | insertAll :: [a] -> Int -> [[a]] -> [[a]] 261 | insertAll xs i [] = error "cannot merge parts that do not exist" 262 | insertAll xs i (ys:yss) 263 | | i == 0 = (xs ++ ys) : yss -- should not need to nub this 264 | | otherwise = ys : insertAll xs (i-1) yss 265 | 266 | ---- Change 267 | 268 | type Part = [Int] 269 | type CmprPart = (Int, Part) 270 | 271 | expand ::CmprPart -> Part 272 | expand (0,p) = p 273 | expand (n,p) = 1:expand ((n-1),p) 274 | 275 | nextpartition :: CmprPart -> CmprPart 276 | nextpartition (k, (x:xs)) = pack (x-1) ((k+x),xs) 277 | 278 | pack :: Int -> CmprPart -> CmprPart 279 | pack 1 (m,xs) = (m,xs) 280 | pack k (m,xs) = if k > m then pack (k-1) (m,xs) 281 | else pack k (m-k,k:xs) 282 | 283 | generatePs :: CmprPart -> [Part] 284 | generatePs p@(n,[]) = [expand p] 285 | generatePs p@(n,(x:xs)) = (expand p: generatePs(nextpartition p)) 286 | 287 | part :: Int -> [Part] 288 | part n 289 | | n < 1 = error "part arg must be >0" 290 | | n == 1 = [[1]] 291 | | otherwise = generatePs (0, [n]) 292 | 293 | change :: [Int] -> Int -> [Part] 294 | change coins n 295 | | 1 `elem` coins = error "One cent coin is assumed. Do not supply it" 296 | | n < 1 = error "Cannot give change of less than one cent" 297 | | n == 1 = [[1]] 298 | | n `elem` coins = generateChange coins (0, [n]) 299 | | otherwise = generateChange coins (nextCoinPartition coins (0, [n])) 300 | 301 | generateChange :: [Int] -> CmprPart -> [Part] 302 | generateChange coins p@(n,[]) = [expand p] 303 | generateChange coins p@(n,(x:xs)) 304 | = expand p : generateChange coins (nextCoinPartition coins p) 305 | 306 | nextCoinPartition :: [Int] -> CmprPart -> CmprPart 307 | nextCoinPartition [] p = error "Ran out of possible coins (should not happen)" 308 | nextCoinPartition coins (k, (x:xs)) = packCoins (newCoins coins) ((k+x),xs) 309 | where 310 | newCoins :: [Int] -> [Int] 311 | newCoins [] = [] 312 | newCoins coins@(c:cs) 313 | | c < x = coins 314 | | otherwise = newCoins cs 315 | 316 | packCoins :: [Int] -> CmprPart -> CmprPart 317 | packCoins [] (m,xs) = (m,xs) 318 | packCoins coins@(c:cs) (m,xs) = if c > m then packCoins cs (m,xs) 319 | else packCoins coins (m-c,c:xs) 320 | 321 | changeEuro :: Int -> [Part] 322 | changeEuro = change [200, 100, 50, 20, 10, 5, 2] 323 | 324 | injs :: [Int] -> [Int] -> [[(Int, Int)]] 325 | injs _ [] = [[]] 326 | injs xs (y:ys) = all_injs y ys xs [] 327 | 328 | all_injs :: Int -> [Int] -> [Int] -> [Int] -> [[(Int, Int)]] 329 | all_injs _ _ [] _ = [] 330 | all_injs y ys (x:xs) xps = 331 | let 332 | rem_xs = glue xps xs 333 | lists = map (\z -> (x, y) : z) (injs rem_xs ys) 334 | in 335 | lists ++ (all_injs y ys xs (x:xps)) 336 | 337 | glue :: [a] -> [a] -> [a] 338 | glue [] xs = xs 339 | glue (x:rev_xs) xs = glue rev_xs (x:xs) 340 | 341 | perms :: [a] -> [[a]] 342 | perms [] = [[]] 343 | perms (x:xs) = concat (map (allPerms x []) (perms xs)) 344 | 345 | allPerms :: a -> [a] -> [a] -> [[a]] 346 | allPerms x pys [] = [glue pys [x]] 347 | allPerms x pys (y:ys) = glue pys (x:y:ys) : allPerms x (y:pys) ys 348 | 349 | -- not convinced this is the prettiest way to do this (see below) 350 | stringCompare :: String -> String -> Maybe Ordering 351 | stringCompare [] [] = Just EQ 352 | stringCompare xs [] = if allAlpha xs then Just GT else Nothing 353 | stringCompare [] xs = if allAlpha xs then Just LT else Nothing 354 | stringCompare (x:xs) (y:ys) 355 | | not (isAlpha x) || not (isAlpha y) = Nothing 356 | | otherwise = case compare x y of 357 | EQ -> stringCompare xs ys; 358 | LT -> if allAlpha xs && allAlpha ys then Just LT else Nothing; 359 | GT -> if allAlpha xs && allAlpha ys then Just GT else Nothing; 360 | 361 | stringCompare' :: String -> String -> Maybe Ordering 362 | stringCompare' xs ys = if allAlpha xs && allAlpha ys 363 | then Just (compare xs ys) else Nothing 364 | 365 | -- if we only care about significant characters 366 | stringCompare'' :: String -> String -> Maybe Ordering 367 | stringCompare'' [] [] = Just EQ 368 | stringCompare'' xs [] = Just GT 369 | stringCompare'' [] xs = Just LT 370 | stringCompare'' (x:xs) (y:ys) 371 | | isAlpha x && isAlpha y = Just (compare x y) 372 | | otherwise = Nothing 373 | 374 | 375 | allAlpha :: String -> Bool 376 | allAlpha = all isAlpha 377 | 378 | isAlpha :: Char -> Bool 379 | isAlpha x = (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') 380 | 381 | data Natural = Z | S Natural 382 | deriving (Eq, Show) 383 | 384 | plus :: Natural -> Natural -> Natural 385 | plus m Z = m 386 | plus m (S n) = S (plus m n) 387 | 388 | leq :: Natural -> Natural -> Bool 389 | leq Z _ = True 390 | leq (S _) Z = False 391 | leq (S m) (S n) = leq m n 392 | 393 | gt :: Natural -> Natural -> Bool 394 | gt m n = not (leq m n) 395 | 396 | lt :: Natural -> Natural -> Bool 397 | lt m n = gt n m 398 | 399 | subtr :: Natural -> Natural -> Natural 400 | subtr m Z = m 401 | subtr Z _ = error "underflow" 402 | subtr (S m) (S n) = subtr m n 403 | 404 | quotient :: Natural -> Natural -> Natural 405 | quotient m Z = error "div zero" 406 | quotient m n = if m `lt` n then Z 407 | else S (quotient (m `subtr` n) n) 408 | 409 | remainder :: Natural -> Natural -> Natural 410 | remainder m Z = error "div zero" 411 | remainder m n = if m `lt` n then m 412 | else remainder (m `subtr` n) n 413 | 414 | catalan :: Int -> Int 415 | catalan 0 = 1 416 | catalan nplus1 = catalan_sum (nplus1 - 1) 0 417 | 418 | catalan_sum :: Int -> Int -> Int 419 | catalan_sum 0 m = (catalan 0) * (catalan m) 420 | catalan_sum n m = (catalan n) * (catalan m) + (catalan_sum (n-1) (m+1)) 421 | 422 | catalans :: [Int] 423 | catalans = map catalan [0..] 424 | 425 | data TernaryTree = L | N TernaryTree TernaryTree TernaryTree deriving Show 426 | 427 | makeTernaryTree :: Integer -> TernaryTree 428 | makeTernaryTree 0 = L 429 | makeTernaryTree n = N (makeTernaryTree (n-1)) (makeTernaryTree (n-1)) (makeTernaryTree (n-1)) 430 | 431 | countTT :: TernaryTree -> Integer 432 | countTT L = 1 433 | countTT (N t1 t2 t3) = 1 + countTT t1 + countTT t2 + countTT t3 434 | 435 | depthTT :: TernaryTree -> Integer 436 | depthTT L = 0 437 | depthTT (N t1 t2 t3) = 1 + (depthTT t1) `max` (depthTT t2) `max` (depthTT t3) 438 | 439 | balancedTT :: TernaryTree -> Bool 440 | balancedTT L = True 441 | balancedTT (N t1 t2 t3) = balancedTT t1 && balancedTT t2 && balancedTT t3 442 | && depthTT t1 == depthTT t2 && depthTT t2 == depthTT t3 443 | 444 | data Tree = Lf | Nd Int Tree Tree deriving Show 445 | 446 | insert :: Int -> Tree -> Tree 447 | insert i Lf = Nd i Lf Lf 448 | insert i n@(Nd j l r) = case compare i j of 449 | EQ -> n; -- just leave the tree alone if it already has our number 450 | LT -> Nd j (insert i l) r; 451 | GT -> Nd j l (insert i r); 452 | 453 | -- this works backwards 454 | makeTree' :: [Int] -> Tree 455 | makeTree' [] = Lf 456 | makeTree' (x:xs) = insert x (makeTree' xs) 457 | 458 | list2tree :: [Int] -> Tree 459 | list2tree = insertAllTree Lf 460 | 461 | insertAllTree :: Tree -> [Int] -> Tree 462 | insertAllTree t [] = t 463 | insertAllTree t (x:xs) = insertAllTree (insert x t) xs 464 | 465 | tree2list :: Tree -> [Int] 466 | tree2list Lf = [] 467 | tree2list (Nd i l r) = tree2list l ++ [i] ++ tree2list r 468 | 469 | contains :: Tree -> Int -> Bool 470 | contains Lf i = False 471 | contains (Nd j l r) i = case compare i j of 472 | EQ -> True; 473 | LT -> contains l i; 474 | GT -> contains r i; 475 | 476 | tree_merge :: Tree -> Tree -> Tree 477 | tree_merge l r = insertAllTree l (tree2list r) 478 | 479 | -- hard to do this without converting to a list 480 | -- tree_merge t Lf = t 481 | -- tree_merge Lf t = t 482 | -- tree_merge n1@(Nd i1 l1 r1) n2@(Nd i2 l2 r2) = case compare i1 i2 of 483 | -- EQ -> Nd i1 (tree_merge l1 l2) (tree_merge r1 r2); 484 | -- LT -> Nd i2 (tree_merge ) 485 | 486 | tree_steps :: Tree -> Int -> Int 487 | tree_steps = tree_steps_int 0 where 488 | tree_steps_int _ Lf _ = -1 489 | tree_steps_int n (Nd j l r) i = case compare i j of 490 | EQ -> n; 491 | LT -> tree_steps_int (n+1) l i; 492 | GT -> tree_steps_int (n+1) r i; 493 | 494 | data Tr a = Nil | T a (Tr a) (Tr a) deriving (Eq, Show) 495 | 496 | mapT :: (a -> b) -> Tr a -> Tr b 497 | mapT _ Nil = Nil 498 | mapT f (T x l r) = T (f x) (mapT f l) (mapT f r) 499 | 500 | foldn :: (a -> a) -> a -> Natural -> a 501 | foldn h c Z = c 502 | foldn h c (S n) = h (foldn h c n) 503 | 504 | foldT :: (a -> b -> b -> b) -> b -> (Tr a) -> b 505 | foldT _ c Nil = c 506 | foldT f c (T x l r) = f x (foldT f c l) (foldT f c r) 507 | 508 | preorder_tree2list :: Tr a -> [a] 509 | preorder_tree2list = foldT (\x l r -> [x] ++ l ++ r) [] 510 | 511 | inorder_tree2list :: Tr a -> [a] 512 | inorder_tree2list = foldT (\x l r -> l ++ [x] ++ r) [] 513 | 514 | postorder_tree2list :: Tr a -> [a] 515 | postorder_tree2list = foldT (\x l r -> l ++ r ++ [x]) [] 516 | 517 | ordered :: Ord a => Tr a -> Bool 518 | ordered = check (\ _ -> True) where 519 | check _ Nil = True 520 | check cond (T x l r) = cond x && check (x) r 521 | 522 | type Dict = Tr (String, String) 523 | 524 | lookupD :: String -> Dict -> [String] 525 | lookupD s Nil = [] 526 | lookupD s (T (k, v) l r) = case compare s k of 527 | EQ -> [v]; 528 | LT -> lookupD s l; 529 | GT -> lookupD s r; 530 | 531 | split :: [a] -> ([a], a, [a]) 532 | split xs = (ys, y, ys2) where 533 | ys = take n xs 534 | (y:ys2) = drop n xs 535 | n = length xs `div` 2 536 | 537 | buildTree :: [a] -> Tr a 538 | buildTree [] = Nil 539 | buildTree xs = 540 | let (ys, y, ys2) = split xs 541 | in T y (buildTree ys) (buildTree ys2) 542 | 543 | data LeafTree a = Leaf a | Node (LeafTree a) (LeafTree a) deriving Show 544 | 545 | ltree :: LeafTree String 546 | ltree = Node (Leaf "I") (Node (Leaf "Love") (Leaf "You")) 547 | 548 | 549 | mapLT :: (a -> b) -> LeafTree a -> LeafTree b 550 | mapLT f (Leaf x) = Leaf (f x) 551 | mapLT f (Node l r) = Node (mapLT f l) (mapLT f r) 552 | 553 | reflect :: LeafTree a -> LeafTree a 554 | reflect (Leaf x) = Leaf x 555 | reflect (Node l r) = Node (reflect r) (reflect l) 556 | 557 | data Rose a = Bud a | Br [Rose a] deriving (Eq, Show) 558 | 559 | rose :: Rose Int 560 | rose = Br [Bud 1, Br [Bud 2, Bud 3, Br [Bud 4, Bud 5, Bud 6]]] 561 | 562 | mapR :: (a -> b) -> Rose a -> Rose b 563 | mapR f (Bud x) = Bud (f x) 564 | mapR f (Br xs) = Br (map (mapR f) xs) 565 | 566 | 567 | genUnion' :: Eq a => [[a]] -> [a] 568 | genUnion' = foldr union [] 569 | 570 | 571 | genIntersect' :: Eq a => [[a]] -> [a] 572 | genIntersect' = foldr1 intersect 573 | 574 | srt :: Ord a => [a] -> [a] 575 | srt = foldr insrt [] 576 | 577 | insrt :: Ord a => a -> [a] -> [a] 578 | insrt x [] = [x] 579 | insrt x (y:ys) 580 | | x < y = x:y:ys 581 | | otherwise = y: (insrt x ys) 582 | 583 | -- Tower of Hanoi 584 | data Peg = A | B | C 585 | type Tower = ([Int], [Int], [Int]) 586 | 587 | move :: Peg -> Peg -> Tower -> Tower 588 | move A B (x:xs, ys, zs) = (xs, x:ys, zs) 589 | move B A (xs, y:ys, zs) = (y:xs, ys, zs) 590 | move A C (x:xs, ys, zs) = (xs, ys, x:zs) 591 | move C A (xs, ys, z:zs) = (z:xs, ys, zs) 592 | move B C (xs, y:ys, zs) = (xs, ys, y:zs) 593 | move C B (xs, ys, z:zs) = (xs, z:ys, zs) 594 | 595 | transfer :: Peg -> Peg -> Peg -> Int -> Tower -> [Tower] 596 | transfer _ _ _ 0 tower = [tower] 597 | transfer p q r n tower = transfer p r q (n-1) tower 598 | ++ transfer r q p (n-1) (move p q tower') 599 | where tower' = last (transfer p r q (n-1) tower) 600 | 601 | hanoi :: Int -> [Tower] 602 | hanoi n = transfer A C B n ([1..n], [], []) 603 | 604 | check :: Int -> Tower -> Bool 605 | check 0 t = t == ([], [], []) 606 | check n (xs, ys, zs) 607 | | xs /= [] && last xs == n = check (n-1) (init xs, zs, ys) 608 | | zs /= [] && last zs == n = check (n-1) (ys, xs, init zs) 609 | | otherwise = False 610 | 611 | maxT :: Tower -> Int 612 | maxT (xs, ys, zs) = foldr max 0 (xs ++ ys ++ zs) 613 | 614 | checkT :: Tower -> Bool 615 | checkT t = check (maxT t) t 616 | --------------------------------------------------------------------------------