diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 69a500d0..7499ad20 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -612,7 +612,7 @@ Fancy: - .fancypack filenames: - Fakefile - + Fantom: type: programming color: "#dbded5" @@ -626,6 +626,12 @@ Forth: extensions: - .4th +Frege: + type: programming + color: "#00cafe" + lexer: Haskell + primary_extension: .fr + Game Maker Language: type: programming lexer: JavaScript diff --git a/lib/linguist/samples.json b/lib/linguist/samples.json index 524fe1c7..b5d92403 100644 --- a/lib/linguist/samples.json +++ b/lib/linguist/samples.json @@ -132,6 +132,9 @@ ".forth", ".fth" ], + "Frege": [ + ".fr" + ], "Game Maker Language": [ ".gml" ], @@ -581,8 +584,8 @@ ".gemrc" ] }, - "tokens_total": 471133, - "languages_total": 584, + "tokens_total": 476697, + "languages_total": 588, "tokens": { "ABAP": { "*/**": 1, @@ -18140,6 +18143,787 @@ "/cell": 2, "cell": 2 }, + "Frege": { + "module": 2, + "examples.CommandLineClock": 1, + "where": 39, + "data": 3, + "Date": 5, + "native": 4, + "java.util.Date": 1, + "new": 9, + "(": 339, + ")": 345, + "-": 730, + "IO": 13, + "MutableIO": 1, + "toString": 2, + "Mutable": 1, + "s": 21, + "ST": 1, + "String": 9, + "d.toString": 1, + "action": 2, + "to": 13, + "give": 2, + "us": 1, + "the": 20, + "current": 4, + "time": 1, + "as": 33, + "do": 38, + "d": 3, + "<->": 35, + "java": 5, + "lang": 2, + "Thread": 2, + "sleep": 4, + "takes": 1, + "a": 99, + "long": 4, + "and": 14, + "returns": 2, + "nothing": 2, + "but": 2, + "may": 1, + "throw": 1, + "an": 6, + "InterruptedException": 4, + "This": 2, + "is": 24, + "without": 1, + "doubt": 1, + "public": 1, + "static": 1, + "void": 2, + "millis": 1, + "throws": 4, + "Encoded": 1, + "in": 22, + "Frege": 1, + "argument": 1, + "type": 8, + "Long": 3, + "result": 11, + "does": 2, + "defined": 1, + "frege": 1, + "Lang": 1, + "main": 11, + "args": 2, + "forever": 1, + "print": 25, + "stdout.flush": 1, + "Thread.sleep": 4, + "examples.Concurrent": 1, + "import": 7, + "System.Random": 1, + "Java.Net": 1, + "URL": 2, + "Control.Concurrent": 1, + "C": 6, + "main2": 1, + "m": 2, + "<": 84, + "newEmptyMVar": 1, + "forkIO": 11, + "m.put": 3, + "replicateM_": 3, + "c": 33, + "m.take": 1, + "println": 25, + "example1": 1, + "putChar": 2, + "example2": 2, + "getLine": 2, + "case": 6, + "of": 32, + "Right": 6, + "n": 38, + "setReminder": 3, + "Left": 5, + "_": 60, + "+": 200, + "show": 24, + "L*n": 1, + "table": 1, + "mainPhil": 2, + "[": 120, + "fork1": 3, + "fork2": 3, + "fork3": 3, + "fork4": 3, + "fork5": 3, + "]": 116, + "mapM": 3, + "MVar": 3, + "1": 2, + "5": 1, + "philosopher": 7, + "Kant": 1, + "Locke": 1, + "Wittgenstein": 1, + "Nozick": 1, + "Mises": 1, + "return": 17, + "Int": 6, + "me": 13, + "left": 4, + "right": 4, + "g": 4, + "Random.newStdGen": 1, + "let": 8, + "phil": 4, + "tT": 2, + "g1": 2, + "Random.randomR": 2, + "L": 6, + "eT": 2, + "g2": 3, + "thinkTime": 3, + "*": 5, + "eatTime": 3, + "fl": 4, + "left.take": 1, + "rFork": 2, + "poll": 1, + "Just": 2, + "fr": 3, + "right.put": 1, + "left.put": 2, + "table.notifyAll": 2, + "Nothing": 2, + "table.wait": 1, + "inter": 3, + "catch": 2, + "getURL": 4, + "xx": 2, + "url": 1, + "URL.new": 1, + "con": 3, + "url.openConnection": 1, + "con.connect": 1, + "con.getInputStream": 1, + "typ": 5, + "con.getContentType": 1, + "stderr.println": 3, + "ir": 2, + "InputStreamReader.new": 2, + "fromMaybe": 1, + "charset": 2, + "unsupportedEncoding": 3, + "br": 4, + "BufferedReader": 1, + "getLines": 1, + "InputStream": 1, + "UnsupportedEncodingException": 1, + "InputStreamReader": 1, + "x": 45, + "x.catched": 1, + "ctyp": 2, + "charset=": 1, + "m.group": 1, + "SomeException": 2, + "Throwable": 1, + "m1": 1, + "MVar.newEmpty": 3, + "m2": 1, + "m3": 2, + "r": 7, + "catchAll": 3, + ".": 41, + "m1.put": 1, + "m2.put": 1, + "m3.put": 1, + "r1": 2, + "m1.take": 1, + "r2": 3, + "m2.take": 1, + "r3": 3, + "take": 13, + "ss": 8, + "mapM_": 5, + "putStrLn": 2, + "|": 62, + "x.getClass.getName": 1, + "y": 15, + "sum": 2, + "map": 49, + "length": 20, + "package": 2, + "examples.Sudoku": 1, + "Data.TreeMap": 1, + "Tree": 4, + "keys": 2, + "Data.List": 1, + "DL": 1, + "hiding": 1, + "find": 20, + "union": 10, + "Element": 6, + "Zelle": 8, + "set": 4, + "candidates": 18, + "Position": 22, + "Feld": 3, + "Brett": 13, + "for": 25, + "assumptions": 10, + "conclusions": 2, + "Assumption": 21, + "ISNOT": 14, + "IS": 16, + "derive": 2, + "Eq": 1, + "Ord": 1, + "instance": 1, + "Show": 1, + "p": 72, + "e": 15, + "pname": 10, + "e.show": 2, + "showcs": 5, + "cs": 27, + "joined": 4, + "Assumption.show": 1, + "elements": 12, + "all": 22, + "possible": 2, + "..": 1, + "positions": 16, + "rowstarts": 4, + "row": 20, + "starting": 3, + "colstarts": 3, + "column": 2, + "boxstarts": 3, + "box": 15, + "boxmuster": 3, + "pattern": 1, + "by": 3, + "adding": 1, + "upper": 2, + "position": 9, + "results": 1, + "real": 1, + "extract": 2, + "field": 9, + "getf": 16, + "f": 19, + "fs": 22, + "fst": 9, + "otherwise": 8, + "cell": 24, + "getc": 12, + "b": 113, + "snd": 20, + "compute": 5, + "list": 7, + "that": 18, + "belong": 3, + "same": 8, + "given": 3, + "z..": 1, + "z": 12, + "quot": 1, + "col": 17, + "mod": 3, + "ri": 2, + "div": 3, + "or": 15, + "depending": 1, + "on": 4, + "ci": 3, + "index": 3, + "middle": 2, + "check": 2, + "if": 5, + "candidate": 10, + "has": 2, + "exactly": 2, + "one": 2, + "member": 1, + "i.e.": 1, + "been": 1, + "solved": 1, + "single": 9, + "Bool": 2, + "true": 16, + "false": 13, + "unsolved": 10, + "rows": 4, + "cols": 6, + "boxes": 1, + "allrows": 8, + "allcols": 5, + "allboxs": 5, + "allrcb": 5, + "zip": 7, + "repeat": 3, + "containers": 6, + "PRINTING": 1, + "printable": 1, + "coordinate": 1, + "a1": 3, + "lower": 1, + "i9": 1, + "packed": 1, + "chr": 2, + "ord": 6, + "board": 41, + "printb": 4, + "p1line": 2, + "pfld": 4, + "line": 2, + "brief": 1, + "no": 4, + "some": 2, + "zs": 1, + "initial/final": 1, + "msg": 6, + "res012": 2, + "concatMap": 1, + "a*100": 1, + "b*10": 1, + "BOARD": 1, + "ALTERATION": 1, + "ACTIONS": 1, + "message": 1, + "about": 1, + "what": 1, + "done": 1, + "turnoff1": 3, + "i": 16, + "off": 11, + "nc": 7, + "head": 19, + "newb": 7, + "filter": 26, + "notElem": 7, + "turnoff": 11, + "turnoffh": 1, + "ps": 8, + "foldM": 2, + "toh": 2, + "setto": 3, + "cname": 4, + "nf": 2, + "SOLVING": 1, + "STRATEGIES": 1, + "reduce": 3, + "sets": 2, + "contains": 1, + "numbers": 1, + "already": 1, + "finds": 1, + "logs": 1, + "NAKED": 5, + "SINGLEs": 1, + "passing.": 1, + "sss": 3, + "each": 2, + "with": 15, + "more": 2, + "than": 2, + "fields": 6, + "are": 6, + "rcb": 16, + "elem": 16, + "collect": 1, + "remove": 3, + "from": 7, + "look": 10, + "number": 4, + "appears": 1, + "container": 9, + "this": 2, + "can": 9, + "go": 1, + "other": 2, + "place": 1, + "HIDDEN": 6, + "SINGLE": 1, + "hiddenSingle": 2, + "select": 1, + "containername": 1, + "FOR": 11, + "IN": 9, + "occurs": 5, + "PAIRS": 8, + "TRIPLES": 8, + "QUADS": 2, + "nakedPair": 4, + "t": 14, + "nm": 6, + "SELECT": 3, + "pos": 5, + "tuple": 2, + "name": 2, + "//": 8, + "u": 6, + "fold": 7, + "non": 2, + "outof": 6, + "tuples": 2, + "hit": 7, + "subset": 3, + "any": 3, + "hiddenPair": 4, + "minus": 2, + "uniq": 4, + "sort": 4, + "common": 4, + "bs": 7, + "undefined": 1, + "cannot": 1, + "happen": 1, + "because": 1, + "either": 1, + "empty": 4, + "not": 5, + "intersectionlist": 2, + "intersections": 2, + "reason": 8, + "reson": 1, + "cpos": 7, + "WHERE": 2, + "tail": 2, + "intersection": 1, + "we": 5, + "occurences": 1, + "XY": 2, + "Wing": 2, + "there": 6, + "exists": 6, + "A": 7, + "X": 5, + "Y": 4, + "B": 5, + "Z": 6, + "shares": 2, + "reasoning": 1, + "will": 4, + "be": 9, + "since": 1, + "indeed": 1, + "thus": 1, + "see": 1, + "xyWing": 2, + "rcba": 4, + "share": 1, + "b1": 11, + "b2": 10, + "&&": 9, + "||": 2, + "then": 1, + "else": 1, + "c1": 4, + "c2": 3, + "N": 5, + "Fish": 1, + "Swordfish": 1, + "Jellyfish": 1, + "When": 2, + "particular": 1, + "digit": 1, + "located": 2, + "only": 1, + "columns": 2, + "eliminate": 1, + "those": 2, + "which": 2, + "fish": 7, + "fishname": 5, + "rset": 4, + "certain": 1, + "rflds": 2, + "rowset": 1, + "colss": 3, + "must": 4, + "appear": 1, + "at": 3, + "least": 3, + "cstart": 2, + "immediate": 1, + "consequences": 6, + "assumption": 8, + "form": 1, + "conseq": 3, + "cp": 3, + "two": 1, + "contradict": 2, + "contradicts": 7, + "get": 3, + "aPos": 5, + "List": 1, + "turned": 1, + "when": 2, + "true/false": 1, + "toClear": 7, + "whose": 1, + "implications": 5, + "themself": 1, + "chain": 2, + "paths": 12, + "solution": 6, + "reverse": 4, + "css": 7, + "yields": 1, + "contradictory": 1, + "chainContra": 2, + "pro": 7, + "contra": 4, + "ALL": 2, + "conlusions": 1, + "uniqBy": 2, + "using": 2, + "sortBy": 2, + "comparing": 2, + "conslusion": 1, + "chains": 4, + "LET": 1, + "BE": 1, + "final": 2, + "conclusion": 4, + "THE": 1, + "FIRST": 1, + "implication": 2, + "ai": 2, + "so": 1, + "a0": 1, + "OR": 7, + "a2": 2, + "...": 2, + "IMPLIES": 1, + "For": 2, + "cells": 1, + "pi": 2, + "have": 1, + "construct": 2, + "p0": 1, + "p1": 1, + "c0": 1, + "cellRegionChain": 2, + "os": 3, + "cellas": 2, + "regionas": 2, + "iss": 3, + "ass": 2, + "first": 2, + "candidates@": 1, + "region": 2, + "oss": 2, + "Liste": 1, + "aller": 1, + "Annahmen": 1, + "ein": 1, + "bestimmtes": 1, + "acstree": 3, + "Tree.fromList": 1, + "bypass": 1, + "maybe": 1, + "tree": 1, + "lookup": 2, + "error": 1, + "performance": 1, + "resons": 1, + "confine": 1, + "ourselves": 1, + "20": 1, + "per": 1, + "mkPaths": 3, + "acst": 3, + "impl": 2, + "{": 1, + "a3": 1, + "ordered": 1, + "impls": 2, + "ns": 2, + "concat": 1, + "takeUntil": 1, + "null": 1, + "iterate": 1, + "expandchain": 3, + "avoid": 1, + "loops": 1, + "uni": 3, + "SOLVE": 1, + "SUDOKU": 1, + "Apply": 1, + "available": 1, + "strategies": 1, + "until": 1, + "changes": 1, + "anymore": 1, + "Strategy": 1, + "functions": 2, + "supposed": 1, + "applied": 1, + "changed": 1, + "board.": 1, + "strategy": 2, + "anything": 1, + "alter": 1, + "it": 2, + "next": 1, + "tried.": 1, + "solve": 19, + "res@": 16, + "apply": 17, + "res": 16, + "smallest": 1, + "comment": 16, + "SINGLES": 1, + "locked": 1, + "2": 3, + "QUADRUPELS": 6, + "3": 3, + "4": 3, + "WINGS": 1, + "FISH": 3, + "pcomment": 2, + "9": 5, + "forcing": 1, + "allow": 1, + "infer": 1, + "both": 1, + "brd": 2, + "com": 5, + "stderr": 3, + "<<": 4, + "log": 1, + "turn": 1, + "string": 3, + "into": 1, + "mkrow": 2, + "mkrow1": 2, + "xs": 4, + "make": 1, + "sure": 1, + "unpacked": 2, + "<=>": 1, + "0": 2, + "ignored": 1, + "h": 1, + "help": 1, + "usage": 1, + "Sudoku": 2, + "file": 4, + "81": 3, + "char": 1, + "consisting": 1, + "digits": 2, + "One": 1, + "such": 1, + "going": 1, + "http": 3, + "www": 1, + "sudokuoftheday": 1, + "pages": 1, + "o": 1, + "php": 1, + "click": 1, + "puzzle": 1, + "open": 1, + "tab": 1, + "Copy": 1, + "address": 1, + "your": 1, + "browser": 1, + "There": 1, + "also": 1, + "hard": 1, + "sudokus": 1, + "examples": 1, + "top95": 1, + "txt": 1, + "W": 1, + "felder": 2, + "decode": 4, + "files": 2, + "forM_": 1, + "sudoku": 2, + "openReader": 1, + "lines": 2, + "BufferedReader.getLines": 1, + "process": 5, + "candi": 2, + "consider": 3, + "acht": 4, + "neun": 2, + "examples.SwingExamples": 1, + "Java.Awt": 1, + "ActionListener": 2, + "Java.Swing": 1, + "rs": 2, + "Runnable.new": 1, + "helloWorldGUI": 2, + "buttonDemoGUI": 2, + "celsiusConverterGUI": 2, + "invokeLater": 1, + "tempTextField": 2, + "JTextField.new": 1, + "celsiusLabel": 1, + "JLabel.new": 3, + "convertButton": 1, + "JButton.new": 3, + "fahrenheitLabel": 1, + "frame": 3, + "JFrame.new": 3, + "frame.setDefaultCloseOperation": 3, + "JFrame.dispose_on_close": 3, + "frame.setTitle": 1, + "celsiusLabel.setText": 1, + "convertButton.setText": 1, + "convertButtonActionPerformed": 2, + "celsius": 3, + "getText": 1, + "double": 1, + "fahrenheitLabel.setText": 3, + "c*1.8": 1, + ".long": 1, + "ActionListener.new": 2, + "convertButton.addActionListener": 1, + "contentPane": 2, + "frame.getContentPane": 2, + "layout": 2, + "GroupLayout.new": 1, + "contentPane.setLayout": 1, + "TODO": 1, + "continue": 1, + "//docs.oracle.com/javase/tutorial/displayCode.html": 1, + "code": 1, + "//docs.oracle.com/javase/tutorial/uiswing/examples/learn/CelsiusConverterProject/src/learn/CelsiusConverterGUI.java": 1, + "frame.pack": 3, + "frame.setVisible": 3, + "label": 2, + "cp.add": 1, + "newContentPane": 2, + "JPanel.new": 1, + "JButton": 4, + "b1.setVerticalTextPosition": 1, + "SwingConstants.center": 2, + "b1.setHorizontalTextPosition": 1, + "SwingConstants.leading": 2, + "b2.setVerticalTextPosition": 1, + "b2.setHorizontalTextPosition": 1, + "b3": 7, + "Enable": 1, + "button": 1, + "setVerticalTextPosition": 1, + "SwingConstants": 2, + "center": 1, + "setHorizontalTextPosition": 1, + "leading": 1, + "setEnabled": 7, + "action1": 2, + "action3": 2, + "b1.addActionListener": 1, + "b3.addActionListener": 1, + "newContentPane.add": 3, + "newContentPane.setOpaque": 1, + "frame.setContentPane": 1 + }, "Game Maker Language": { "//draws": 1, "the": 62, @@ -51271,6 +52055,7 @@ "Erlang": 2928, "fish": 636, "Forth": 1516, + "Frege": 5564, "Game Maker Language": 13310, "GAS": 133, "GLSL": 3766, @@ -51424,6 +52209,7 @@ "Erlang": 5, "fish": 3, "Forth": 7, + "Frege": 4, "Game Maker Language": 13, "GAS": 1, "GLSL": 3, @@ -51539,5 +52325,5 @@ "Xtend": 2, "YAML": 2 }, - "md5": "ae61e5c2d20e71a1a9df118bf8ea7a82" + "md5": "278ea8642dd01d246a77d63cdb053bfb" } \ No newline at end of file diff --git a/samples/Frege/CommandLineClock.fr b/samples/Frege/CommandLineClock.fr new file mode 100644 index 00000000..5bdde621 --- /dev/null +++ b/samples/Frege/CommandLineClock.fr @@ -0,0 +1,44 @@ +{-- + This program displays the + current time on stdandard output + every other second. + -} + +module examples.CommandLineClock where + +data Date = native java.util.Date where + native new :: () -> IO (MutableIO Date) -- new Date() + native toString :: Mutable s Date -> ST s String -- d.toString() + +--- 'IO' action to give us the current time as 'String' +current :: IO String +current = do + d <- Date.new () + d.toString + +{- + "java.lang.Thread.sleep" takes a "long" and + returns nothing, but may throw an InterruptedException. + This is without doubt an IO action. + + public static void sleep(long millis) + throws InterruptedException + + Encoded in Frege: + - argument type long Long + - result void () + - does IO IO () + - throws ... throws .... + +-} +-- .... defined in frege.java.Lang +-- native sleep java.lang.Thread.sleep :: Long -> IO () throws InterruptedException + + +main args = + forever do + current >>= print + print "\r" + stdout.flush + Thread.sleep 999 + \ No newline at end of file diff --git a/samples/Frege/Concurrent.fr b/samples/Frege/Concurrent.fr new file mode 100644 index 00000000..5f9df994 --- /dev/null +++ b/samples/Frege/Concurrent.fr @@ -0,0 +1,147 @@ +module examples.Concurrent where + +import System.Random +import Java.Net (URL) +import Control.Concurrent as C + +main2 args = do + m <- newEmptyMVar + forkIO do + m.put 'x' + m.put 'y' + m.put 'z' + replicateM_ 3 do + c <- m.take + print "got: " + println c + + +example1 = do + forkIO (replicateM_ 100000 (putChar 'a')) + replicateM_ 100000 (putChar 'b') + +example2 = do + s <- getLine + case s.long of + Right n -> forkIO (setReminder n) >> example2 + Left _ -> println ("exiting ...") + +setReminder :: Long -> IO () +setReminder n = do + println ("Ok, I remind you in " ++ show n ++ " seconds") + Thread.sleep (1000L*n) + println (show n ++ " seconds is up!") + +table = "table" + +mainPhil _ = do + [fork1,fork2,fork3,fork4,fork5] <- mapM MVar.new [1..5] + forkIO (philosopher "Kant" fork5 fork1) + forkIO (philosopher "Locke" fork1 fork2) + forkIO (philosopher "Wittgenstein" fork2 fork3) + forkIO (philosopher "Nozick" fork3 fork4) + forkIO (philosopher "Mises" fork4 fork5) + return () + +philosopher :: String -> MVar Int -> MVar Int -> IO () +philosopher me left right = do + g <- Random.newStdGen + let phil g = do + let (tT,g1) = Random.randomR (60L, 120L) g + (eT, g2) = Random.randomR (80L, 160L) g1 + thinkTime = 300L * tT + eatTime = 300L * eT + + println(me ++ " is going to the dining room and takes his seat.") + fl <- left.take + println (me ++ " takes up left fork (" ++ show fl ++ ")") + rFork <- right.poll + case rFork of + Just fr -> do + println (me ++ " takes up right fork. (" ++ show fr ++ ")") + println (me ++ " is going to eat for " ++ show eatTime ++ "ms") + Thread.sleep eatTime + println (me ++ " finished eating.") + right.put fr + println (me ++ " took down right fork.") + left.put fl + println (me ++ " took down left fork.") + table.notifyAll + println(me ++ " is going to think for " ++ show thinkTime ++ "ms.") + Thread.sleep thinkTime + phil g2 + Nothing -> do + println (me ++ " finds right fork is already in use.") + left.put fl + println (me ++ " took down left fork.") + table.notifyAll + println (me ++ " is going to the bar to await notifications from table.") + table.wait + println (me ++ " got notice that something changed at the table.") + phil g2 + + inter :: InterruptedException -> IO () + inter _ = return () + + phil g `catch` inter + + +getURL xx = do + url <- URL.new xx + con <- url.openConnection + con.connect + is <- con.getInputStream + typ <- con.getContentType + -- stderr.println ("content-type is " ++ show typ) + ir <- InputStreamReader.new is (fromMaybe "UTF-8" (charset typ)) + `catch` unsupportedEncoding is + br <- BufferedReader.new ir + br.getLines + where + unsupportedEncoding :: InputStream -> UnsupportedEncodingException -> IO InputStreamReader + unsupportedEncoding is x = do + stderr.println x.catched + InputStreamReader.new is "UTF-8" + + charset ctyp = do + typ <- ctyp + case typ of + m~´charset=(\S+)´ -> m.group 1 + _ -> Nothing + + +type SomeException = Throwable + +main ["dining"] = mainPhil [] + +main _ = do + m1 <- MVar.newEmpty + m2 <- MVar.newEmpty + m3 <- MVar.newEmpty + + forkIO do + r <- (catchAll . getURL) "http://www.wikipedia.org/wiki/Haskell" + m1.put r + + forkIO do + r <- (catchAll . getURL) "htto://www.wikipedia.org/wiki/Java" + m2.put r + + forkIO do + r <- (catchAll . getURL) "http://www.wikipedia.org/wiki/Frege" + m3.put r + + r1 <- m1.take + r2 <- m2.take + r3 <- m3.take + println (result r1, result r2, result r3) + -- case r3 of + -- Right ss -> mapM_ putStrLn ss + -- Left _ -> return () + where + result :: (SomeException|[String]) -> (String|Int) + result (Left x) = Left x.getClass.getName + result (Right y) = (Right . sum . map length) y + -- mapM_ putStrLn r2 + + \ No newline at end of file diff --git a/samples/Frege/Sudoku.fr b/samples/Frege/Sudoku.fr new file mode 100644 index 00000000..88bfd966 --- /dev/null +++ b/samples/Frege/Sudoku.fr @@ -0,0 +1,561 @@ +package examples.Sudoku where + +import Data.TreeMap (Tree, keys) +import Data.List as DL hiding (find, union) + + +type Element = Int -- 1,2,3,4,5,6,7,8,9 +type Zelle = [Element] -- set of candidates +type Position = Int -- 0..80 +type Feld = (Position, Zelle) +type Brett = [Feld] + +--- data type for assumptions and conclusions +data Assumption = + !ISNOT Position Element + | !IS Position Element + + +derive Eq Assumption +derive Ord Assumption +instance Show Assumption where + show (IS p e) = pname p ++ "=" ++ e.show + show (ISNOT p e) = pname p ++ "/" ++ e.show + +showcs cs = joined " " (map Assumption.show cs) + +elements :: [Element] -- all possible elements +elements = [1 .. 9] + +{- + a b c d e f g h i + 0 1 2 | 3 4 5 | 6 7 8 1 + 9 10 11 |12 13 14 |15 16 17 2 + 18 19 20 |21 22 23 |24 25 26 3 + ---------|---------|-------- + 27 28 29 |30 31 32 |33 34 35 4 + 36 37 38 |39 40 41 |42 43 44 5 + 45 46 47 |48 49 50 |51 52 53 6 + ---------|---------|-------- + 54 55 56 |57 58 59 |60 61 62 7 + 63 64 65 |66 67 68 |69 70 71 8 + 72 73 74 |75 76 77 |78 79 80 9 +-} + +positions :: [Position] -- all possible positions +positions = [0..80] +rowstarts :: [Position] -- all positions where a row is starting +rowstarts = [0,9,18,27,36,45,54,63,72] +colstarts :: [Position] -- all positions where a column is starting +colstarts = [0,1,2,3,4,5,6,7,8] +boxstarts :: [Position] -- all positions where a box is starting +boxstarts = [0,3,6,27,30,33,54,57,60] +boxmuster :: [Position] -- pattern for a box, by adding upper left position results in real box +boxmuster = [0,1,2,9,10,11,18,19,20] + + +--- extract field for position +getf :: Brett -> Position -> Feld +getf (f:fs) p + | fst f == p = f + | otherwise = getf fs p +getf [] p = (p,[]) + + +--- extract cell for position +getc :: Brett -> Position -> Zelle +getc b p = snd (getf b p) + +--- compute the list of all positions that belong to the same row as a given position +row :: Position -> [Position] +row p = [z..(z+8)] where z = (p `quot` 9) * 9 + +--- compute the list of all positions that belong to the same col as a given position +col :: Position -> [Position] +col p = map (c+) rowstarts where c = p `mod` 9 + +--- compute the list of all positions that belong to the same box as a given position +box :: Position -> [Position] +box p = map (z+) boxmuster where + ri = p `div` 27 * 27 -- 0, 27 or 54, depending on row + ci = p `mod` 9 -- column index 0..8, 0,1,2 is left, 3,4,5 is middle, 6,7,8 is right + cs = ci `div` 3 * 3 -- 0, 3 or 6 + z = ri + cs + +--- check if candidate set has exactly one member, i.e. field has been solved +single :: Zelle -> Bool +single [_] = true +single _ = false + +unsolved :: Zelle -> Bool +unsolved [_] = false +unsolved _ = true + +-- list of rows, cols, boxes +allrows = map row rowstarts +allcols = map col colstarts +allboxs = map box boxstarts +allrcb = zip (repeat "row") allrows + ++ zip (repeat "col") allcols + ++ zip (repeat "box") allboxs + + +containers :: [(Position -> [Position], String)] +containers = [(row, "row"), (col, "col"), (box, "box")] + +-- ----------------- PRINTING ------------------------------------ +-- printable coordinate of field, upper left is a1, lower right is i9 +pname p = packed [chr (ord 'a' + p `mod` 9), chr (ord '1' + p `div` 9)] + +-- print board +printb b = mapM_ p1line allrows >> println "" + where + p1line row = do + print (joined "" (map pfld line)) + where line = map (getc b) row + +-- print field (brief) +-- ? = no candidate +-- 5 = field is 5 +-- . = some candidates +pfld [] = "?" +pfld [x] = show x +pfld zs = "0" + +-- print initial/final board +result msg b = do + println ("Result: " ++ msg) + print ("Board: ") + printb b + return b + +res012 b = case concatMap (getc b) [0,1,2] of + [a,b,c] -> a*100+b*10+c + _ -> 9999999 + +-- -------------------------- BOARD ALTERATION ACTIONS --------------------------------- +-- print a message about what is done to the board and return the new board +turnoff1 :: Position -> Zelle -> Brett -> IO Brett +turnoff1 i off b + | single nc = do + -- print (pname i) + -- print ": set to " + -- print (head nc) + -- println " (naked single)" + return newb + | otherwise = return newb + where + cell = getc b i + nc = filter (`notElem` off) cell + newb = (i, nc) : [ f | f <- b, fst f != i ] + +turnoff :: Int -> Zelle -> String -> Brett -> IO Brett +turnoff i off msg b = do + -- print (pname i) + -- print ": set to " + -- print nc + -- print " by clearing " + -- print off + -- print " " + -- println msg + return newb + where + cell = getc b i + nc = filter (`notElem` off) cell + newb = (i, nc) : [ f | f <- b, fst f != i ] + +turnoffh ps off msg b = foldM toh b ps + where + toh b p = turnoff p off msg b + +setto :: Position -> Element -> String -> Brett -> IO Brett +setto i n cname b = do + -- print (pname i) + -- print ": set to " + -- print n + -- print " (hidden single in " + -- print cname + -- println ")" + return newb + where + nf = [n] + newb = (i, nf) : [ f | f <- b, fst f != i ] + + +-- ----------------------------- SOLVING STRATEGIES --------------------------------------------- +-- reduce candidate sets that contains numbers already in same row, col or box +-- This finds (and logs) NAKED SINGLEs in passing. +reduce b = [ turnoff1 p sss | (p,cell) <- b, -- for each field + unsolved cell, -- with more than 1 candidate + -- single fields in containers that are candidates of that field + sss = [ s | (rcb, _) <- containers, [s] <- map (getc b) (rcb p), s `elem` cell], + sss != [] ] -- collect field index, elements to remove from candidate set + +-- look for a number that appears in exactly 1 candidate set of a container +-- this number can go in no other place (HIDDEN SINGLE) +hiddenSingle b = [ setto i n cname | -- select index, number, containername + (cname, rcb) <- allrcb, -- FOR rcb IN allrcb + n <- elements, -- FOR n IN elements + fs = filter (unsolved • snd) (map (getf b) rcb), + occurs = filter ((n `elem`) • snd) fs, + length occurs == 1, + (i, _) <- occurs ] + +-- look for NAKED PAIRS, TRIPLES, QUADS +nakedPair n b = [ turnoff p t ("(naked tuple in " ++ nm ++ ")") | -- SELECT pos, tuple, name + -- n <- [2,3,4], // FOR n IN [2,3,4] + (nm, rcb) <- allrcb, -- FOR rcb IN containers + fs = map (getf b) rcb, -- let fs = fields for rcb positions + u = (fold union [] . filter unsolved . map snd) fs, -- let u = union of non single candidates + t <- n `outof` u, -- FOR t IN n-tuples + hit = (filter ((`subset` t) . snd) . filter (unsolved . snd)) fs, + length hit == n, + (p, cell) <- fs, + p `notElem` map fst hit, + any (`elem` cell) t + ] + +-- look for HIDDEN PAIRS, TRIPLES or QUADS +hiddenPair n b = [ turnoff p off ("(hidden " ++ show t ++ " in " ++ nm ++ ")") | -- SELECT pos, tuple, name + -- n <- [2,3,4], // FOR n IN [2,3,4] + (nm, rcb) <- allrcb, -- FOR rcb IN containers + fs = map (getf b) rcb, -- let fs = fields for rcb positions + u = (fold union [] . filter ((>1) . length) . map snd) fs, -- let u = union of non single candidates + t <- n `outof` u, -- FOR t IN n-tuples + hit = (filter (any ( `elem` t) . snd) . filter (unsolved . snd)) fs, + length hit == n, + off = (fold union [] . map snd) hit `minus` t, + off != [], + (p, cell) <- hit, + ! (cell `subset` t) + ] + +a `subset` b = all (`elem` b) a +a `union` b = uniq (sort (a ++ b)) +a `minus` b = filter (`notElem` b) a +a `common` b = filter (`elem` b) a +n `outof` as + | length as < n = [] + | [] <- as = [] + | 1 >= n = map (:[]) as + | (a:bs) <- as = map (a:) ((n-1) `outof` bs) ++ (n `outof` bs) + | otherwise = undefined -- cannot happen because either as is empty or not + +same f a b = b `elem` f a + +intersectionlist = [(allboxs, row, "box/row intersection"), (allboxs, col, "box/col intersection"), + (allrows ++ allcols, box, "line/box intersection")] +intersections b = [ + turnoff pos [c] reason | -- SELECT position, candidate, reson + (from, container, reason) <- intersectionlist, + rcb <- from, + fs = (filter (unsolved . snd) . map (getf b)) rcb, -- fs = fields in from with more than 1 candidate + c <- (fold union [] • map snd) fs, -- FOR c IN union of candidates + cpos = (map fst • filter ((c `elem`) • snd)) fs, -- cpos = positions where c occurs + cpos != [], -- WHERE cpos is not empty + all (same container (head cpos)) (tail cpos), -- WHERE all positions are in the intersection + -- we can remove all occurences of c that are in container, but not in from + (pos, cell) <- map (getf b) (container (head cpos)), + c `elem` cell, + pos `notElem` rcb ] + + +-- look for an XY Wing +-- - there exists a cell A with candidates X and Y +-- - there exists a cell B with candidates X and Z that shares a container with A +-- - there exists a cell C with candidates Y and Z that shares a container with A +-- reasoning +-- - if A is X, B will be Z +-- - if A is Y, C will be Z +-- - since A will indeed be X or Y -> B or C will be Z +-- - thus, no cell that can see B and C can be Z +xyWing board = [ turnoff p [z] ("xy wing " ++ pname b ++ " " ++ pname c ++ " because of " ++ pname a) | + (a, [x,y]) <- board, -- there exists a cell a with candidates x and y + rcba = map (getf board) (row a ++ col a ++ box a), -- rcba = all fields that share a container with a + (b, [b1, b2]) <- rcba, + b != a, + b1 == x && b2 != y || b2 == x && b1 != y, -- there exists a cell B with candidates x and z + z = if b1 == x then b2 else b1, + (c, [c1, c2]) <- rcba, + c != a, c!= b, + c1 == y && c2 == z || c1 == z && c2 == y, -- there exists a cell C with candidates y and z + ps = (uniq . sort) ((row b ++ col b ++ box b) `common` (row c ++ col c ++ box c)), + -- remove z in ps + (p, cs) <- map (getf board) ps, + p != b, p != c, + z `elem` cs ] + +-- look for a N-Fish (2: X-Wing, 3: Swordfish, 4: Jellyfish) +-- When all candidates for a particular digit in N rows are located +-- in only N columns, we can eliminate all candidates from those N columns +-- which are not located on those N rows +fish n board = fish "row" allrows row col ++ fish "col" allcols col row where + fishname 2 = "X-Wing" + fishname 3 = "Swordfish" + fishname 4 = "Jellyfish" + fishname _ = "unknown fish" + fish nm allrows row col = [ turnoff p [x] (fishname n ++ " in " ++ nm ++ " " ++ show (map (pname . head) rset)) | + rset <- n `outof` allrows, -- take n rows (or cols) + x <- elements, -- look for certain number + rflds = map (filter ((>1) . length . snd) . map (getf board)) rset, -- unsolved fields in the rowset + colss = (map (map (head . col . fst) . filter ((x `elem`) . snd)) rflds), -- where x occurs in candidates + all ((>1) . length) colss, -- x must appear in at least 2 cols + cols = fold union [] colss, + length cols == n, + cstart <- cols, + (p, cell) <- map (getf board) (col cstart), + x `elem` cell, + all (p `notElem`) rset] + + +-- compute immediate consequences of an assumption of the form (p `IS` e) or (p `ISNOT` e) +conseq board (IS p e) = uniq (sort ([ p `ISNOT` x | x <- getc board p, x != e ] ++ + [ a `ISNOT` e | + (a,cs) <- map (getf board) (row p ++ col p ++ box p), + a != p, + e `elem` cs + ])) +conseq board (ISNOT p e) = uniq (sort ([ p `IS` x | cs = getc board p, length cs == 2, x <- cs, x != e ] ++ + [ a `IS` e | + cp <- [row p, box p, col p], + as = (filter ((e `elem`) . getc board) . filter (p!=)) cp, + length as == 1, + a = head as + ])) + +-- check if two assumptions contradict each other +contradicts (IS a x) (IS b y) = a==b && x!=y +contradicts (IS a x) (ISNOT b y) = a==b && x==y +contradicts (ISNOT a x) (IS b y) = a==b && x==y +contradicts (ISNOT _ _) (ISNOT _ _) = false + +-- get the Position of an Assumption +aPos (IS p _) = p +aPos (ISNOT p _) = p + +-- get List of elements that must be turned off when assumption is true/false +toClear board true (IS p x) = filter (x!=) (getc board p) +toClear board false (IS p x) = [x] +toClear board true (ISNOT p x) = [x] +toClear board false (ISNOT p x) = filter (x!=) (getc board p) + + +-- look for assumptions whose implications contradict themself +chain board paths = [ solution a (head cs) (reverse cs) | + (a, css) <- paths, + cs <- take 1 [ cs | cs <- css, contradicts a (head cs) ] + ] + where + solution a c cs = turnoff (aPos a) (toClear board false a) reason where + reason = "Assumption " ++ show a ++ " implies " ++ show c ++ "\n\t" + ++ showcs cs ++ "\n\t" + ++ "Therefore, " ++ show a ++ " must be false." + +-- look for an assumption that yields to contradictory implications +-- this assumption must be false +chainContra board paths = [ solution a (reverse pro) (reverse contra) | + (a, css) <- paths, -- FOR ALL assumptions "a" with list of conlusions "css" + (pro, contra) <- take 1 [ (pro, contra) | + pro <- (uniqBy (using head) . sortBy (comparing head)) css, -- FOR ALL conslusion chains "pro" + c = head pro, -- LET "c" BE the final conclusion + contra <- take 1 (filter ((contradicts c) . head) css) -- THE FIRST conclusion that contradicts c + ] + ] + where + solution a pro con = turnoff (aPos a) (toClear board false a) reason where + reason = ("assumption " ++ show a ++ " leads to contradictory conclusions\n\t" + ++ showcs pro ++ "\n\t" ++ showcs con) + + + +-- look for a common implication c of some assumptions ai, where at least 1 ai is true +-- so that (a0 OR a1 OR a2 OR ...) IMPLIES c +-- For all cells pi in same container that have x as candidate, we can construct (p0==x OR p1==x OR ... OR pi==x) +-- For a cell p with candidates ci, we can construct (p==c0 OR p==c1) +cellRegionChain board paths = [ solution b as (map head os) | + as <- cellas ++ regionas, -- one of as must be true + iss = filter ((`elem` as) . fst) paths, -- the implications for as + (a, ass) <- take 1 iss, -- implications for first assumption + fs <- (uniqBy (using head) . sortBy (comparing head)) ass, + b = head fs, -- final conclusions of first assumption + os = [fs] : map (take 1 . filter ((b==) . head) . snd) (tail iss), -- look for implications with same conclusion + all ([]!=) os] + where + cellas = [ map (p `IS`) candidates | (p, candidates@(_:_:_)) <- board ] + regionas = [ map (`IS` e) ps | + region <- map (map (getf board)) (allrows ++ allcols ++ allboxs), + e <- elements, + ps = map fst (filter ((e `elem`) . snd) region), + length ps > 1 ] + solution b as oss = turnoff (aPos b) (toClear board true b) reason where + reason = "all of the assumptions " ++ joined ", " (map show as) ++ " imply " ++ show b ++ "\n\t" + ++ joined "\n\t" (map (showcs . reverse) oss) ++ "\n\t" + ++ "One of them must be true, so " ++ show b ++ " must be true." + + +{- + Wir brauchen für einige Funktionen eine Datenstruktur wie + [ (Assumption, [[Assumption]]) ] + d.i. eine Liste von möglichen Annahmen samt aller Schlußketten. + Idealerweise sollte die Schlußkette in umgekehrter Reihenfolge vorliegen, + dann kann man einfach finden: + - Annahmen, die zum Selbstwiderspruch führen. + - alles, was aus einer bestimmten Annahme folgt (map (map head) [[a]]) + -... +-} +--- Liste aller Annahmen für ein bestimmtes Brett +assumptions :: Brett -> [Assumption] +assumptions board = [ a | + (p, cs) <- board, + !(single cs), + a <- map (ISNOT p) cs ++ map (IS p) cs ] + +consequences :: Brett -> [Assumption] -> [[Assumption]] +consequences board as = map (conseq board) as + +acstree :: Brett -> Tree Assumption [Assumption] +acstree board = Tree.fromList (zip as cs) + where + as = assumptions board + cs = consequences board as + +-- bypass maybe on tree lookup +find :: Tree Assumption [Assumption] -> Assumption -> [Assumption] +find t a + | Just cs <- t.lookup a = cs + | otherwise = error ("no consequences for " ++ show a) + +-- for performance resons, we confine ourselves to implication chains of length 20 per assumption +mkPaths :: Tree Assumption [Assumption] -> [ (Assumption, [[Assumption]]) ] +mkPaths acst = map impl (keys acst) -- {[a1], [a2], [a3] ] + where + -- [Assumption] -> [(a, [chains, ordered by length] + impl a = (a, impls [[a]]) + impls ns = (take 1000 • concat • takeUntil null • iterate expandchain) ns + -- expandchain :: [[Assumption]] -> [[Assumption]] + expandchain css = [ (n:a:as) | + (a : as) <- css, -- list of assumptions + n <- find acst a, -- consequences of a + n `notElem` as -- avoid loops + ] + -- uni (a:as) = a : uni (filter ((head a !=) • head) as) + -- uni [] = empty + -- empty = [] + + +-- ------------------ SOLVE A SUDOKU -------------------------- +-- Apply all available strategies until nothing changes anymore +-- Strategy functions are supposed to return a list of +-- functions, which, when applied to a board, give a changed board. +-- When a strategy does not find anything to alter, +-- it returns [], and the next strategy can be tried. +solve b + | all (single . snd) b = result "Solved" b + | any (([]==) . snd) b = result "not solvable" b + | res@(_:_) <- reduce b = apply b res >>=solve -- compute smallest candidate sets + -- comment "candidate sets are up to date" = () + | res@(_:_) <- hiddenSingle b = apply b res >>= solve -- find HIDDEN SINGLES + -- comment "no more hidden singles" = () + | res@(_:_) <- intersections b = apply b res >>= solve -- find locked candidates + -- comment "no more intersections" = () + | res@(_:_) <- nakedPair 2 b = apply b res >>= solve -- find NAKED PAIRS, TRIPLES or QUADRUPELS + -- comment "no more naked pairs" = () + | res@(_:_) <- hiddenPair 2 b = apply b res >>= solve -- find HIDDEN PAIRS, TRIPLES or QUADRUPELS + -- comment "no more hidden pairs" = () + -- res@(_:_) <- nakedPair 3 b = apply b res >>= solve // find NAKED PAIRS, TRIPLES or QUADRUPELS + -- | comment "no more naked triples" = () + -- res@(_:_) <- hiddenPair 3 b = apply b res >>= solve // find HIDDEN PAIRS, TRIPLES or QUADRUPELS + -- | comment "no more hidden triples" = () + -- res@(_:_) <- nakedPair 4 b = apply b res >>=solve // find NAKED PAIRS, TRIPLES or QUADRUPELS + -- | comment "no more naked quadruples" = () + -- res@(_:_) <- hiddenPair 4 b = apply b res >>=solve // find HIDDEN PAIRS, TRIPLES or QUADRUPELS + -- | comment "no more hidden quadruples" = () + | res@(_:_) <- xyWing b = apply b res >>=solve -- find XY WINGS + -- comment "no more xy wings" = () + | res@(_:_) <- fish 2 b = apply b res >>=solve -- find 2-FISH + -- comment "no more x-wings" = () + -- res@(_:_) <- fish 3 b = apply b res >>=solve // find 3-FISH + -- | comment "no more swordfish" = () + -- res@(_:_) <- fish 4 b = apply b res >>=solve // find 4-FISH + -- | comment "no more jellyfish" = () + -- | comment pcomment = () + | res@(_:_) <- chain b paths = apply b (take 9 res) >>= solve -- find forcing chains + | res@(_:_) <- cellRegionChain b paths = apply b (take 9 res) >>= solve -- find common conclusion for true assumption + | res@(_:_) <- chainContra b paths = apply b (take 9 res) >>= solve -- find assumptions that allow to infer both a and !a + -- comment "consistent conclusions only" = () + + | otherwise = result "ambiguous" b + where + apply brd fs = foldM (\b\f -> f b) brd fs + paths = mkPaths (acstree b) + -- pcomment = show (length paths) ++ " assumptions with " ++ show (fold (+) 0 (map (length <~ snd) paths)) + -- ++ " implication chains" + +-- comment com = do stderr << com << "\n" for false +-- log com = do stderr << com << "\n" for true + +--- turn a string into a row +mkrow :: String -> [Zelle] +mkrow s = mkrow1 xs + where + xs = s ++ "---------" -- make sure at least 9 elements + mkrow1 xs = (take 9 • filter ([]!=) • map f • unpacked) xs + f x | x >= '1' && x <= '9' = [ord x - ord '0'] + | x == ' ' = [] -- ignored + | otherwise = elements + +main ["-h"] = main [] +main ["-help"] = main [] +main [] = do + mapM_ stderr.println [ + "usage: java Sudoku file ...", + " java Sudoku position", + "where position is a 81 char string consisting of digits", + "One can get such a string by going to", + "http://www.sudokuoftheday.com/pages/s-o-t-d.php", + "Right click on the puzzle and open it in new tab", + "Copy the 81 digits from the URL in the address field of your browser.", + "", + "There is also a file with hard sudokus in examples/top95.txt\n"] + return () + + +main [s@#^[0-9\W]{81}$#] = solve board >> return () + where + board = zip positions felder + felder = decode s + +main files = forM_ files sudoku + where + sudoku file = do + br <- openReader file + lines <- BufferedReader.getLines br + bs <- process lines + ss <- mapM (\b -> print "Puzzle: " >> printb b >> solve b) bs + println ("Euler: " ++ show (sum (map res012 ss))) + return () + +-- "--3-" => [1..9, 1..9, [3], 1..9] +decode s = map candi (unpacked s) where + candi c | c >= '1' && c <= '9' = [(ord c - ord '0')] + | otherwise = elements +process [] = return [] +process (s:ss) + | length s == 81 = consider b1 + | length s == 9, + length acht == 8, + all ((9==) • length) acht = consider b2 + | otherwise = do + stderr.println ("skipped line: " ++ s) + process ss + where + acht = take 8 ss + neun = fold (++) "" (s:acht) + b1 = zip positions (decode s) + b2 = zip positions (decode neun) + consider b = do + -- print "Puzzle: " + -- printb b + bs <- process ss + return (b:bs) + diff --git a/samples/Frege/SwingExamples.fr b/samples/Frege/SwingExamples.fr new file mode 100644 index 00000000..73569546 --- /dev/null +++ b/samples/Frege/SwingExamples.fr @@ -0,0 +1,79 @@ +package examples.SwingExamples where + +import Java.Awt (ActionListener) +import Java.Swing + + +main _ = do + rs <- mapM Runnable.new [helloWorldGUI, buttonDemoGUI, celsiusConverterGUI] + mapM_ invokeLater rs + println "Hit enter to end ...." + s <- getLine + return () + +celsiusConverterGUI = do + tempTextField <- JTextField.new() + celsiusLabel <- JLabel.new () + convertButton <- JButton.new () + fahrenheitLabel <- JLabel.new () + frame <- JFrame.new () + frame.setDefaultCloseOperation JFrame.dispose_on_close + frame.setTitle "Celsius Converter" + celsiusLabel.setText "Celsius" + convertButton.setText "Convert" + let convertButtonActionPerformed _ = do + celsius <- tempTextField.getText + case celsius.double of + Left _ -> fahrenheitLabel.setText ("not a valid number: " ++ celsius) + Right c -> fahrenheitLabel.setText (show (c*1.8 + 32.0).long ++ " Fahrenheit") + return () + ActionListener.new convertButtonActionPerformed >>= convertButton.addActionListener + fahrenheitLabel.setText "Fahrenheit" + contentPane <- frame.getContentPane + layout <- GroupLayout.new contentPane + contentPane.setLayout layout + -- TODO continue + -- http://docs.oracle.com/javase/tutorial/displayCode.html?code=http://docs.oracle.com/javase/tutorial/uiswing/examples/learn/CelsiusConverterProject/src/learn/CelsiusConverterGUI.java + frame.pack + frame.setVisible true + +helloWorldGUI = do + frame <- JFrame.new "Hello World Frege" + frame.setDefaultCloseOperation(JFrame.dispose_on_close) + label <- JLabel.new "Hello World!" + cp <- frame.getContentPane + cp.add label + frame.pack + frame.setVisible true + +buttonDemoGUI = do + frame <- JFrame.new "Button Demo" + frame.setDefaultCloseOperation(JFrame.dispose_on_close) + newContentPane <- JPanel.new () + b1::JButton <- JButton.new "Disable middle button" + b1.setVerticalTextPosition SwingConstants.center + b1.setHorizontalTextPosition SwingConstants.leading + b2::JButton <- JButton.new "Middle button" + b2.setVerticalTextPosition SwingConstants.center + b2.setHorizontalTextPosition SwingConstants.leading + b3::JButton <- JButton.new "Enable middle button" + b3.setVerticalTextPosition SwingConstants.center + b3.setHorizontalTextPosition SwingConstants.leading + b3.setEnabled false + let action1 _ = do + b2.setEnabled false + b1.setEnabled false + b3.setEnabled true + action3 _ = do + b2.setEnabled true + b1.setEnabled true + b3.setEnabled false + ActionListener.new action1 >>= b1.addActionListener + ActionListener.new action3 >>= b3.addActionListener + newContentPane.add b1 + newContentPane.add b2 + newContentPane.add b3 + newContentPane.setOpaque true + frame.setContentPane newContentPane + frame.pack + frame.setVisible true