├── test ├── interpreter-test-suite │ ├── fail.fq │ ├── let-tup.fq │ ├── qft1.fq │ ├── let-tup-q.fq │ ├── id.fq │ ├── tdagger.fq │ ├── nic-test.fq │ ├── partial-app-meas.fq │ ├── partial-app-new.fq │ ├── second.fq │ ├── frac-phase.fq │ ├── pauliX.fq │ ├── pauliY.fq │ ├── pauliZ.fq │ ├── qft2.fq │ ├── third.fq │ ├── toffoli.fq │ ├── second-q.fq │ ├── qft3.fq │ ├── equals.fq │ ├── plus.fq │ ├── cnot.fq │ ├── partial-app-cnot.fq │ ├── seventh.fq │ ├── swap.fq │ ├── qft4.fq │ ├── swapTwice.fq │ ├── phase.fq │ ├── qft5.fq │ ├── partial-app-qmap.fq │ ├── nested-let.fq │ ├── deutsch.fq │ ├── higher-order-function.fq │ ├── fredkin.fq │ ├── partial-app-comp.fq │ ├── teleport.fq │ ├── partial-app-multiple.fq │ ├── qft-adder4.fq │ └── qpe.fq ├── Spec.hs ├── InterpreterTests.hs ├── QStateTests.hs ├── GatesTests.hs └── TestCore.hs ├── Setup.hs ├── src ├── Parser │ ├── Test │ ├── Abs.hi │ ├── Abs.o │ ├── Lex.hi │ ├── Lex.o │ ├── Par.hi │ ├── Par.o │ ├── Print.o │ ├── Skel.hi │ ├── Skel.o │ ├── Test.hi │ ├── Test.o │ ├── Print.hi │ ├── Abs.hs │ ├── Abs.hs.bak │ ├── Test.hs │ ├── Test.hs.bak │ ├── ErrM.hs │ ├── Parser.cf │ ├── Skel.hs │ ├── Skel.hs.bak │ ├── Doc.txt │ ├── Doc.txt.bak │ ├── Par.y │ ├── Par.y.bak │ ├── Lex.x │ ├── Lex.x.bak │ ├── Print.hs.bak │ └── Print.hs ├── Makefile ├── Makefile.bak ├── FunQ.hs ├── Lib │ ├── Core.hs │ ├── Internal │ │ ├── Core.hs │ │ └── Gates.hs │ ├── QM.hs │ └── Gates.hs ├── Interpreter │ ├── Interpreter.hs │ └── Run.hs ├── SemanticAnalysis │ └── SemanticAnalysis.hs ├── AST │ └── AST.hs └── Type │ └── TypeChecker.hs ├── docsImages ├── h.PNG ├── s.PNG ├── t.PNG ├── x.PNG ├── y.PNG ├── z.PNG ├── cnot.PNG └── toffoli.PNG ├── examples ├── coinFlip.fq ├── deutsch.fq ├── CoinFlip.hs ├── teleport.fq ├── grovers.fq ├── berstein-vazirani.fq ├── shors.fq ├── Deutsch.hs ├── DeutschJozsa.hs └── Teleport.hs ├── .gitignore ├── ext └── vim │ └── funQ.vim ├── README.md ├── .github └── workflows │ └── pages.yml ├── stack.yaml.lock ├── Makefile ├── app ├── Main.hs └── Repl.hs ├── Makefile.bak ├── package.yaml ├── stack.yaml ├── legacy ├── QOps.hs ├── Gates.hs └── QData.hs └── qfunc.cabal /test/interpreter-test-suite/fail.fq: -------------------------------------------------------------------------------- 1 | f : QBit 2 | f = 0 -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Parser/Test: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Test -------------------------------------------------------------------------------- /docsImages/h.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/h.PNG -------------------------------------------------------------------------------- /docsImages/s.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/s.PNG -------------------------------------------------------------------------------- /docsImages/t.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/t.PNG -------------------------------------------------------------------------------- /docsImages/x.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/x.PNG -------------------------------------------------------------------------------- /docsImages/y.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/y.PNG -------------------------------------------------------------------------------- /docsImages/z.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/z.PNG -------------------------------------------------------------------------------- /src/Parser/Abs.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Abs.hi -------------------------------------------------------------------------------- /src/Parser/Abs.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Abs.o -------------------------------------------------------------------------------- /src/Parser/Lex.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Lex.hi -------------------------------------------------------------------------------- /src/Parser/Lex.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Lex.o -------------------------------------------------------------------------------- /src/Parser/Par.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Par.hi -------------------------------------------------------------------------------- /src/Parser/Par.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Par.o -------------------------------------------------------------------------------- /src/Parser/Print.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Print.o -------------------------------------------------------------------------------- /src/Parser/Skel.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Skel.hi -------------------------------------------------------------------------------- /src/Parser/Skel.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Skel.o -------------------------------------------------------------------------------- /src/Parser/Test.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Test.hi -------------------------------------------------------------------------------- /src/Parser/Test.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Test.o -------------------------------------------------------------------------------- /test/interpreter-test-suite/let-tup.fq: -------------------------------------------------------------------------------- 1 | main : Bit 2 | main = let (x,y) = (0,1) in x -- 0 -------------------------------------------------------------------------------- /docsImages/cnot.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/cnot.PNG -------------------------------------------------------------------------------- /src/Parser/Print.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/src/Parser/Print.hi -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft1.fq: -------------------------------------------------------------------------------- 1 | main : Bit 2 | main = meas (QFTI1 (QFT1 (new 0))) -- 0 -------------------------------------------------------------------------------- /docsImages/toffoli.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NicklasBoto/funQ/HEAD/docsImages/toffoli.PNG -------------------------------------------------------------------------------- /test/interpreter-test-suite/let-tup-q.fq: -------------------------------------------------------------------------------- 1 | main : Bit 2 | main = let (x,y) = (new 0, new 1) in meas x -- 0 -------------------------------------------------------------------------------- /examples/coinFlip.fq: -------------------------------------------------------------------------------- 1 | coinFlip : !Bit 2 | coinFlip = measure (H (new 0)) 3 | 4 | main : Bit 5 | main = coinFlip -------------------------------------------------------------------------------- /test/interpreter-test-suite/id.fq: -------------------------------------------------------------------------------- 1 | id : QBit -o Bit 2 | id b = meas (I b) 3 | 4 | main : Bit 5 | main = id (new 1) -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/tdagger.fq: -------------------------------------------------------------------------------- 1 | t : QBit -o QBit 2 | t q = T q 3 | 4 | main : Bit 5 | main = meas (t (new 1)) -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/nic-test.fq: -------------------------------------------------------------------------------- 1 | q : QBit 2 | q = H (new 0) 3 | 4 | main : (Bit >< Bit) 5 | main = (measure q, measure q) -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-meas.fq: -------------------------------------------------------------------------------- 1 | measP : QBit -o Bit 2 | measP = meas 3 | 4 | main : Bit 5 | main = measP (new 0) -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-new.fq: -------------------------------------------------------------------------------- 1 | newP : Bit -o QBit 2 | newP = new 3 | 4 | main : Bit 5 | main = meas (newP 1) -------------------------------------------------------------------------------- /test/interpreter-test-suite/second.fq: -------------------------------------------------------------------------------- 1 | second : Bit -o Bit -o Bit 2 | second x y = y 3 | 4 | main : Bit 5 | main = second 0 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/frac-phase.fq: -------------------------------------------------------------------------------- 1 | main : Bit >< Bit 2 | main = let (a,b) = (QFTI2 (CR12 (QFT2 (new 1, new 1)))) in (meas a, meas b) -------------------------------------------------------------------------------- /test/interpreter-test-suite/pauliX.fq: -------------------------------------------------------------------------------- 1 | pauliX : QBit -o QBit 2 | pauliX q = X q 3 | 4 | main : Bit 5 | main = meas (pauliX (new 0)) -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/pauliY.fq: -------------------------------------------------------------------------------- 1 | pauliY : QBit -o QBit 2 | pauliY q = Y q 3 | 4 | main : Bit 5 | main = meas (pauliY (new 0)) -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/pauliZ.fq: -------------------------------------------------------------------------------- 1 | pauliZ : QBit -o QBit 2 | pauliZ q = Z q 3 | 4 | main : Bit 5 | main = meas (pauliZ (new 0)) -- 0 -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft2.fq: -------------------------------------------------------------------------------- 1 | main : Bit >< Bit 2 | main = let (x,y) = QFTI2 (QFT2 ((new 0), (new 1))) in (meas x, meas y) -- (0, 1) -------------------------------------------------------------------------------- /test/interpreter-test-suite/third.fq: -------------------------------------------------------------------------------- 1 | third : Bit -o Bit -o Bit -o Bit 2 | third x y z = z 3 | 4 | main : Bit 5 | main = third 0 0 1 -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/toffoli.fq: -------------------------------------------------------------------------------- 1 | main : (Bit >< Bit >< Bit) 2 | main = let (a,b,c) = TOFFOLI (in1, in2, in3) in (meas a, meas b, meas c) -------------------------------------------------------------------------------- /test/interpreter-test-suite/second-q.fq: -------------------------------------------------------------------------------- 1 | second : QBit -o QBit -o QBit 2 | second x y = y 3 | 4 | main : Bit 5 | main = meas (second (new 1) (new 0)) -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft3.fq: -------------------------------------------------------------------------------- 1 | main : Bit >< Bit >< Bit 2 | main = let (x,y,z) = QFTI3 (QFT3 ((new 0), (new 1), (new 0))) in (meas x, meas y, meas z) -- (0,1,0) -------------------------------------------------------------------------------- /test/interpreter-test-suite/equals.fq: -------------------------------------------------------------------------------- 1 | eq : Bit -o Bit -o Bit 2 | eq a b = if a then (if b then 1 else 0) else (if b then 0 else 1) 3 | 4 | main : Bit 5 | main = eq 0 0 -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/plus.fq: -------------------------------------------------------------------------------- 1 | plus : Bit -o Bit -o Bit 2 | plus a b = if a then (if b then 0 else 1) else (if b then 1 else 0) 3 | 4 | main : Bit 5 | main = plus 0 0 -------------------------------------------------------------------------------- /test/interpreter-test-suite/cnot.fq: -------------------------------------------------------------------------------- 1 | cnot : QBit -o QBit -o (QBit >< QBit) 2 | cnot a b = CNOT (a, b) 3 | 4 | main : Bit 5 | main = let (x,y) = (cnot (new 1) (new 1)) in (meas y) -- 0 -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-cnot.fq: -------------------------------------------------------------------------------- 1 | cnot : (QBit >< QBit) -o (QBit >< QBit) 2 | cnot = CNOT 3 | 4 | main : Bit 5 | main = let (a, b) = cnot (new 1, new 0) in meas b -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/seventh.fq: -------------------------------------------------------------------------------- 1 | seventh : Bit -o Bit -o Bit -o Bit -o Bit -o Bit -o Bit -o Bit 2 | seventh a b c d e f g = g 3 | 4 | main : Bit 5 | main = seventh 1 1 1 1 1 1 0 -------------------------------------------------------------------------------- /test/interpreter-test-suite/swap.fq: -------------------------------------------------------------------------------- 1 | swap : QBit -o QBit -o (QBit >< QBit) 2 | swap a b = SWAP (a,b) 3 | 4 | main : Bit 5 | main = let (a, b) = swap (new 1) (new 0) in meas b -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft4.fq: -------------------------------------------------------------------------------- 1 | main : Bit >< Bit >< Bit >< Bit 2 | main = let (x,y,z,w) = QFTI4 (QFT4 ((new 0), (new 1), (new 0), (new 1))) in (meas x, meas y, meas z, meas w) -- (0,1,0,1) 3 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/swapTwice.fq: -------------------------------------------------------------------------------- 1 | swap : !(QBit -o QBit -o (QBit >< QBit)) 2 | swap a b = SWAP (a,b) 3 | 4 | main : Bit 5 | main = let (a, b) = swap (new 1) (new 0) in let (c,d) = swap a b in meas c -- 1 -------------------------------------------------------------------------------- /test/interpreter-test-suite/phase.fq: -------------------------------------------------------------------------------- 1 | phase : QBit -o QBit 2 | phase q = S q 3 | 4 | main : Bit 5 | main = meas (phase (new 0)) -- 0 6 | 7 | -- phase ger blandat utfall 1 och 0 (ca. 50 / 50) för qbit 1, alltid 0 för 0 -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft5.fq: -------------------------------------------------------------------------------- 1 | 2 | main : Bit >< Bit >< Bit >< Bit >< Bit 3 | main = let (x,y,z,w, a) = QFTI5 (QFT5 ((new 1), (new 0), (new 1), (new 0), (new 1))) in (meas x, meas y, meas z, meas w, meas a) -- (1,0,1,0,1) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | 4 | # latex-filer 5 | .aux 6 | .fdb_latexmk 7 | .fls 8 | .log 9 | .pdf 10 | .synctex.gz 11 | 12 | # Ignore haddock 13 | docs/ 14 | ext/vsc/funq-syntax-highlighting/vsc-extension-quickstart.md 15 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-qmap.fq: -------------------------------------------------------------------------------- 1 | qmap : (QBit -o QBit) -o (QBit >< QBit) -o (QBit >< QBit) 2 | qmap f a = let (x,y) = a in (f x, y) 3 | 4 | measureFst : (QBit >< QBit) -o Bit 5 | measureFst q = let (a,b) = q in meas a 6 | 7 | main : Bit 8 | main = measureFirst (qmap X (new 1, new 1)) -- 0 -------------------------------------------------------------------------------- /examples/deutsch.fq: -------------------------------------------------------------------------------- 1 | balanced : (QBit >< QBit) -o QBit 2 | balanced qs = let (x,y) = qs in 3 | let (x,y) = CNOT (X x, y) 4 | in (X x) 5 | 6 | deutsch : ((QBit >< QBit) -o QBit) -o !Bit 7 | deutsch oracle = measure (H (oracle (H (new 0), H (new 1)))) 8 | 9 | main : !Bit 10 | main = deutsch balanced 11 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/nested-let.fq: -------------------------------------------------------------------------------- 1 | -- let (a,b,c) = M in N 2 | -- blir 3 | -- let (a,b) = M in let (b,c) = b in N 4 | -- 1) interpreter kan hantera nästlade let 5 | -- 2) få let (a,b,c) att funka 6 | 7 | main : Bit 8 | main = let (a,b,c,d) = m in meas b 9 | 10 | -- let (a,b) = m in let (c,d) = b in meas d 11 | 12 | m : (QBit >< QBit >< QBit >< QBit) 13 | m = (new 1, new 0, new 1, new 1) -------------------------------------------------------------------------------- /test/interpreter-test-suite/deutsch.fq: -------------------------------------------------------------------------------- 1 | balanced : (QBit >< QBit) -o (QBit >< QBit) 2 | balanced qs = let (x,y) = qs in 3 | let (x,y) = CNOT (X x, y) 4 | in (X x, y) 5 | 6 | deutsch : ((QBit >< QBit) -o (QBit >< QBit)) -o !Bit 7 | deutsch oracle = 8 | let (x,y) = oracle (H (new 0), H (new 1)) 9 | in measure (H x) 10 | 11 | main : !Bit 12 | main = deutsch balanced -------------------------------------------------------------------------------- /test/interpreter-test-suite/higher-order-function.fq: -------------------------------------------------------------------------------- 1 | appFst : (QBit -o QBit) -o (QBit >< QBit) -o (QBit >< QBit) 2 | appFst f a = let (x,y) = a in (f x, y) 3 | 4 | measureFst : (QBit >< QBit) -o Bit 5 | measureFst q = let (a,b) = q in meas a 6 | 7 | measureBoth : (QBit >< QBit) -o (Bit >< Bit) 8 | measureBoth q = let (a, b) = q in (meas a, meas b) 9 | 10 | main : (Bit >< Bit) 11 | main = measureBoth (appFst X (new 1, new 1)) -- (0,1) -------------------------------------------------------------------------------- /test/interpreter-test-suite/fredkin.fq: -------------------------------------------------------------------------------- 1 | fredkin : QBit -o QBit -o QBit -o QBit >< QBit >< QBit 2 | fredkin a b c = FREDKIN (a,b,c) 3 | 4 | -- fredkin : QBit -o QBit -o QBit -o QBit 5 | -- fredkin a b c = c 6 | 7 | main : QBit >< QBit >< QBit 8 | main = fredkin (new 1) (new 1) (new 1) 9 | 10 | -- let (x,y) = fredkin (new 1) (new 1) (new 1) in let (a,b) = y in (meas b) -- 0 11 | 12 | -- let (x,(y,z)) = fredkin (new 1) (new 1) (new 1) in (meas x,(meas y, meas z)) 13 | 14 | 15 | -------------------------------------------------------------------------------- /ext/vim/funQ.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: funQ 3 | " Maintainer: qfunc@nicbot.xyz 4 | " Latest Revision: 15 March 2021 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | syn match fqGates /\u+/ 11 | hi def link fqGates Special 12 | 13 | syn keyword fqBuiltin new meas measure 14 | hi def link fqBuiltin Define 15 | 16 | syn match fqLambda /\(λ\|\\\)/ 17 | hi def link fqLambda Special 18 | 19 | syn keyword fqBit 0 1 20 | hi def link fqBit Number 21 | -------------------------------------------------------------------------------- /examples/CoinFlip.hs: -------------------------------------------------------------------------------- 1 | module CoinFlip where 2 | 3 | 4 | import FunQ 5 | 6 | -- | Given two values, will return either of them with a 50% probability. 7 | 8 | -- Example usage: 9 | -- :l examples/CoinFlip.hs -- Load the haskell file 10 | -- run $ coinFlip "hard brackets" "parenthesis" 11 | 12 | coinFlip :: a -> b -> QM (Either a b) 13 | coinFlip left right = do 14 | q <- new 0 15 | q <- hadamard q 16 | b <- measure q 17 | return $ if b == 0 then Left left else Right right 18 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-comp.fq: -------------------------------------------------------------------------------- 1 | main : Bit 2 | main = measureFst (multiple (new 1, new 1)) -- 0 3 | 4 | comp : ((QBit >< QBit) -o (QBit >< QBit)) -o ((QBit >< QBit) -o (QBit >< QBit)) -o ((QBit >< QBit) -o (QBit >< QBit)) 5 | comp f g = \x: QBit >< QBit . f (g x) 6 | 7 | multiple : (QBit >< QBit) -o (QBit >< QBit) 8 | multiple = comp SWAP CNOT 9 | 10 | measureFst : (QBit >< QBit) -o Bit 11 | measureFst q = let (a,b) = q in meas a 12 | 13 | measureSnd : (QBit >< QBit) -o Bit 14 | measureSnd q = let (a,b) = q in meas b -------------------------------------------------------------------------------- /examples/teleport.fq: -------------------------------------------------------------------------------- 1 | -- teleport example 2 | 3 | bellMeasure : QBit -o QBit -o (Bit >< Bit) 4 | bellMeasure a b = let (x,y) = CNOT (a,b) in (measure (H x), measure y) 5 | 6 | epr : T -o QBit >< QBit 7 | epr x = CNOT (H (new 0), new 0) 8 | 9 | correction : QBit -o ((Bit >< Bit) -o QBit) 10 | correction q bits = let (a,b) = bits in 11 | if a then (if b then Z (X q) else Z q) 12 | else (if b then X q else I q) 13 | 14 | teleport : QBit -o QBit 15 | teleport psi = let (a,b) = epr * in correction b (bellMeasure a psi) 16 | 17 | q : Bit 18 | q = 0 -------------------------------------------------------------------------------- /examples/grovers.fq: -------------------------------------------------------------------------------- 1 | -- Grover's Algorithm 2 | 3 | par : !(!(QBit -o QBit) -o !((QBit >< QBit) -o QBit >< QBit)) 4 | par g qs = let (p,q) = qs in (g p, g q) 5 | 6 | diffuser : !((QBit >< QBit) -o QBit >< QBit) 7 | diffuser qs = par H $ CR1 $ par Z $ par H qs 8 | 9 | -- Encodes the list [2,5,1,7] with a winner of 7 10 | oracle : !((QBit >< QBit) -o QBit >< QBit) 11 | oracle = CR1 12 | 13 | grover : !(QBit -o QBit -o QBit >< QBit) 14 | grover q0 q1 = diffuser $ oracle $ par H (q0,q1) 15 | 16 | main : Bit >< Bit 17 | main = let (a,b) = grover (new 0) (new 0) in (measure a, measure b) 18 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/teleport.fq: -------------------------------------------------------------------------------- 1 | bellMeasure : QBit -o QBit -o (Bit >< Bit) 2 | bellMeasure q2 q1 = let (x,y) = CNOT (q1,q2) in (measure (H x), measure y) 3 | 4 | epr : T -o QBit >< QBit 5 | epr x = CNOT (H (new 0), new 0) 6 | 7 | correction : QBit -o ((Bit >< Bit) -o QBit) 8 | correction q bits = let (x,y) = bits in 9 | if x then (if y then Z (X q) else Z q) 10 | else (if y then X q else I q) 11 | 12 | teleport : QBit -o QBit 13 | teleport psi = let (x,y) = epr * in correction y (bellMeasure x psi) 14 | 15 | main : Bit 16 | main = measure (teleport (new 1)) 17 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Main where 4 | import QStateTests ( runTests ) 5 | import GatesTests ( runTests ) 6 | import InterpreterTests ( runTests ) 7 | import TypeCheckTests ( runTests ) 8 | import System.Exit ( exitFailure, exitSuccess ) 9 | 10 | main :: IO () 11 | main = sequence tests >>= \b -> if and b then exitSuccess else exitFailure 12 | where tests = [ QStateTests.runTests 13 | , GatesTests.runTests 14 | , InterpreterTests.runTests 15 | , TypeCheckTests.runTests 16 | ] 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # funQ - Functional Quantum Programming 2 | 3 | funQ is a functional domain specific programming language with affine types. 4 | The syntax and type system is based on the theoretical quantum lambda calculus, [described here](https://arxiv.org/abs/cs/0404056). 5 | 6 | ## Installation 7 | You need to have [stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) installed. Some users may also have to install `blas` and `lapack`. 8 | 9 | ``` 10 | $ git clone https://github.com/NicklasBoto/funQ.git 11 | $ cd funQ 12 | $ stack install 13 | ``` 14 | 15 | Make sure you have the install location on your `PATH` (stack will tell you where this is). 16 | -------------------------------------------------------------------------------- /examples/berstein-vazirani.fq: -------------------------------------------------------------------------------- 1 | -- BV 2 | 3 | par : !(!(QBit -o QBit) -o !((QBit >< QBit) -o QBit >< QBit)) 4 | par g qs = let (p,q) = qs in (g p, g q) 5 | 6 | groverOperator : !((QBit >< QBit) -o QBit >< QBit) 7 | groverOperator qs = let (p,q) = par X $ par H qs in 8 | let (q,p) = CNOT (q, H p) in 9 | par H $ par X (H p, q) 10 | 11 | bernsteinVazirani : !((QBit >< QBit >< QBit) -o QBit >< QBit) 12 | bernsteinVazirani qs = let (a,b,c) = qs in 13 | let (c,b,a) = TOFFOLI (H c, H b, H $ X a) in 14 | groverOperator (b,c) 15 | 16 | main : Bit >< Bit 17 | main = let (a,b) = bernsteinVazirani (new 0, new 0, new 0) in (measure a, measure b) -------------------------------------------------------------------------------- /examples/shors.fq: -------------------------------------------------------------------------------- 1 | init : !((QBit >< QBit >< QBit >< QBit >< QBit) -o QBit >< QBit >< QBit >< QBit >< QBit) 2 | init qs = let (a,b,c,d,e) = qs in 3 | let (a,b,c) = QFT3 (a,b,c) in (a,b,c,d,e) 4 | 5 | shor : !((QBit >< QBit >< QBit >< QBit >< QBit) -o QBit >< QBit >< QBit >< QBit >< QBit) 6 | shor qs = let (a,b,c,d,e) = init qs in 7 | let (b,c,d) = (H b, CNOT (c,d)) in 8 | let (c,e) = CNOT (c,e) in 9 | let (b,a) = CR2 (b,a) in 10 | let (a,b,c) = (H a, CR4 (b,c)) in 11 | let (a,c) = CR2 (a,c) in (a,b,c,d,e) 12 | 13 | main : Bit >< Bit >< Bit >< Bit >< Bit 14 | main = let (a,b,c,d,e) = shor (new 0, new 0, new 0, new 0, new 0) 15 | in (measure a, measure b, measure c, 0, 0) -------------------------------------------------------------------------------- /examples/Deutsch.hs: -------------------------------------------------------------------------------- 1 | -- | The Deustch Oracle algorithm 2 | module Deutsch where 3 | 4 | import FunQ 5 | 6 | type Oracle = (QBit, QBit) -> QM (QBit, QBit) 7 | 8 | -- | An oracle with a constant function 9 | constant :: Oracle 10 | constant (x,y) = do 11 | z <- new 0 12 | swap (z, x) 13 | cnot (x, y) 14 | swap (z, x) 15 | return (x, y) 16 | 17 | -- | An oracle with a balanced function 18 | balanced :: Oracle 19 | balanced (x,y) = do 20 | pauliX x 21 | cnot (x,y) 22 | pauliX x 23 | return (x, y) 24 | 25 | -- | Will return a 1 if balanced and 0 if constant. 26 | deutsch :: Oracle -> QM Bit 27 | deutsch oracle = do 28 | x <- new 0 29 | y <- new 1 30 | hadamard x 31 | hadamard y 32 | oracle (x, y) 33 | hadamard x 34 | measure x -------------------------------------------------------------------------------- /test/interpreter-test-suite/partial-app-multiple.fq: -------------------------------------------------------------------------------- 1 | qmap : (QBit -o QBit) -o (QBit >< QBit) -o (QBit >< QBit) 2 | qmap f a = let (x,y) = a in (f x, y) 3 | 4 | -- fmap : (a -o b) -o (a >< c) -o (b >< c) 5 | -- fmap g qs = let (x,y) = qs in (g x, y) 6 | 7 | main : Bit 8 | main = measureFst (multiple (new 1, new 1)) -- 0 -- measureSnd (multiple (new 1, new 1)) -- measureFirst (multiple (new 1, new 1)) -- 0 -- measureFirst (id (qmap X (new 1, new 1))) -- 0 9 | 10 | comp : (b -o c) -o (a -o b) -o (a -o c) 11 | comp f g = \x . f (g x) 12 | 13 | multiple : a -o a 14 | multiple = comp SWAP CNOT 15 | 16 | measureFst : (QBit >< QBit) -o Bit 17 | measureFst q = let (a,b) = q in meas a 18 | 19 | measureSnd : (QBit >< QBit) -o Bit 20 | measureSnd q = let (a,b) = q in meas b 21 | 22 | id : QBit -o QBit 23 | id = I -------------------------------------------------------------------------------- /.github/workflows/pages.yml: -------------------------------------------------------------------------------- 1 | name: github-pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | 8 | jobs: 9 | deploy: 10 | name: Generate docs and deploy to github pages 11 | runs-on: ubuntu-latest 12 | 13 | steps: 14 | - name: Checkout code 15 | uses: actions/checkout@v2 16 | 17 | - name: Generate docs 18 | run: stack haddock --no-haddock-deps && mkdir docs && cp -r $(stack path --local-install-root)/doc/* docs && cp -r docsImages docs/qfunc-0.1.0.0/images 19 | 20 | - name: Add CNAME 21 | run: echo "qfunc.nicbot.xyz" > docs/CNAME 22 | 23 | - name: Deploy to github pages 24 | uses: peaceiris/actions-gh-pages@v3 25 | with: 26 | github_token: ${{ secrets.GITHUB_TOKEN }} 27 | publish_dir: ./docs 28 | 29 | -------------------------------------------------------------------------------- /examples/DeutschJozsa.hs: -------------------------------------------------------------------------------- 1 | -- | The Deustch-Jozsa Oracle algorithm 2 | module DeutschJozsa where 3 | 4 | import FunQ 5 | import Control.Monad ( replicateM ) 6 | 7 | type Oracle = ([QBit], QBit) -> QM ([QBit], QBit) 8 | 9 | -- | An oracle with a balanced function 10 | balanced :: Oracle 11 | balanced (xs,y) = do 12 | mapM_ pauliX xs 13 | mapM_ (\q -> cnot (q,y)) xs 14 | mapM_ pauliX xs 15 | return (xs, y) 16 | 17 | -- | An oracle with a constant function 18 | constant :: Oracle 19 | constant (xs,y) = do 20 | zs <- replicateM (length xs) (new 0) 21 | mapM_ swap $ zip xs zs 22 | mapM_ (\q -> cnot (q,y)) xs 23 | mapM_ swap $ zip xs zs 24 | return (xs, y) 25 | 26 | -- | Will return a list of ones if balanced and list of zeros if constant. 27 | -- Size is the number of qubit inputs to the oracle. 28 | deutschJozsa :: Int -> Oracle -> QM [Bit] 29 | deutschJozsa size oracle = do 30 | xs <- replicateM size (new 0) 31 | y <- new 1 32 | mapM_ hadamard xs 33 | hadamard y 34 | oracle (xs, y) 35 | mapM_ hadamard xs 36 | mapM measure xs 37 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: repline-0.4.0.0@sha256:3324479e497d27c40c3d4762bffc52058f9921621d20d2947dcf9a554b94cd0d,2253 9 | pantry-tree: 10 | size: 564 11 | sha256: bff43f9a5b0a212c29c12e2e22b528d9071b2a7d13489ce5bdc54ae9eac853cf 12 | original: 13 | hackage: repline-0.4.0.0@sha256:3324479e497d27c40c3d4762bffc52058f9921621d20d2947dcf9a554b94cd0d,2253 14 | - completed: 15 | hackage: haskeline-0.8.1.1@sha256:21c0d6bd9f36a8b0cfbceab30820f4fe4ac72535c4d2cdf217123d816a4e494e,5818 16 | pantry-tree: 17 | size: 2955 18 | sha256: 38e3a32dea678bed9da7ae3a70fa371e130ea2c8666ab7b836172f6323d9f2ea 19 | original: 20 | hackage: haskeline-0.8.1.1@sha256:21c0d6bd9f36a8b0cfbceab30820f4fe4ac72535c4d2cdf217123d816a4e494e,5818 21 | snapshots: 22 | - completed: 23 | size: 532172 24 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/18.yaml 25 | sha256: 4f2a092c6f4869854e8d7435ab98ce5157c641022c3cbfc4c4614ff3db752e62 26 | original: 27 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/18.yaml 28 | -------------------------------------------------------------------------------- /test/interpreter-test-suite/qft-adder4.fq: -------------------------------------------------------------------------------- 1 | exIntA : (QBit >< QBit >< QBit >< QBit) 2 | exIntA = (new 0, new 1, new 1, new 1) 3 | 4 | exIntB : (QBit >< QBit >< QBit >< QBit) 5 | exIntB = (new 0, new 1, new 1, new 1) 6 | 7 | cAdd : (QBit >< QBit >< QBit >< QBit) 8 | cAdd = let (b3, b2, b1, b0) = exIntB in 9 | let (a0, a1, a2, a3) = swap4 (QFT4 exIntA) in 10 | let (b31, a01) = CR (b3, a0) in -- 2^1 11 | let (b21, a02) = CR2 (b2, a01) in -- 2^2 12 | let (b11, a03) = CR4 (b1, a02) in -- 2^3 13 | let (b01, a04) = CR8 (b0, a03) in -- 2^4 14 | 15 | let (b22, a11) = CR (b21, a1) in -- 2^1 16 | let (b12, a12) = CR2 (b11, a11) in -- 2^2 17 | let (b02, a13) = CR4 (b01, a12) in -- 2^3 18 | 19 | let (b13, a21) = CR (b12, a2) in -- 2^1 20 | let (b03, a22) = CR2 (b02, a21) in -- 2^2 21 | 22 | let (b04, a31) = CR (b03, a3) in -- 2^1 23 | 24 | QFTI4 (swap4 (a04, a13, a22, a31)) 25 | 26 | swap4 : !((QBit >< QBit >< QBit >< QBit) -o (QBit >< QBit >< QBit >< QBit)) 27 | swap4 q = let (a,b,c,d) = q in 28 | let (a1,d1) = SWAP (a,d) in 29 | let (b1,c1) = SWAP (b,c) in 30 | (a1,b1,c1,d1) 31 | 32 | meas4 : (QBit >< QBit >< QBit >< QBit) -o (Bit >< Bit >< Bit >< Bit) 33 | meas4 q = let (a,b,c,d) = q in (meas a,meas b,meas c,meas d) 34 | 35 | main : Bit >< Bit >< Bit >< Bit 36 | main = meas4 cAdd -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile generated by BNFC. 2 | 3 | # List of goals not corresponding to file names. 4 | 5 | .PHONY : all clean distclean 6 | 7 | # Default goal. 8 | 9 | all : Parser/Test 10 | 11 | # Rules for building the parser. 12 | 13 | Parser/ErrM.hs Parser/Lex.x Parser/Print.hs Parser/Par.y Parser/Test.hs : src/Parser/Parser.cf 14 | bnfc --haskell -d src/Parser/Parser.cf 15 | 16 | %.hs : %.y 17 | happy --ghc --coerce --array --info $< 18 | 19 | %.hs : %.x 20 | alex --ghc $< 21 | 22 | Parser/Test : Parser/Test.hs Parser/ErrM.hs Parser/Lex.hs Parser/Par.hs Parser/Print.hs 23 | ghc --make $< -o $@ 24 | 25 | # Rules for cleaning generated files. 26 | 27 | clean : 28 | -rm -f Parser/*.hi Parser/*.o Parser/*.log Parser/*.aux Parser/*.dvi 29 | 30 | distclean : clean 31 | -rm -f Parser/Abs.hs Parser/Abs.hs.bak Parser/ComposOp.hs Parser/ComposOp.hs.bak Parser/Doc.txt Parser/Doc.txt.bak Parser/ErrM.hs Parser/ErrM.hs.bak Parser/Layout.hs Parser/Layout.hs.bak Parser/Lex.x Parser/Lex.x.bak Parser/Par.y Parser/Par.y.bak Parser/Print.hs Parser/Print.hs.bak Parser/SharedString.hs Parser/SharedString.hs.bak Parser/Skel.hs Parser/Skel.hs.bak Parser/Test.hs Parser/Test.hs.bak Parser/XML.hs Parser/XML.hs.bak Parser/AST.agda Parser/AST.agda.bak Parser/Parser.agda Parser/Parser.agda.bak Parser/IOLib.agda Parser/IOLib.agda.bak Parser/Main.agda Parser/Main.agda.bak Parser/Parser.dtd Parser/Parser.dtd.bak Parser/Test Parser/Lex.hs Parser/Par.hs Parser/Par.info Parser/ParData.hs Makefile 32 | -rmdir -p Parser/ 33 | 34 | # EOF 35 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile generated by BNFC. 2 | 3 | # List of goals not corresponding to file names. 4 | 5 | .PHONY : all clean distclean 6 | 7 | # Default goal. 8 | 9 | all : Parser/Test 10 | 11 | # Rules for building the parser. 12 | 13 | Parser/ErrM.hs Parser/Lex.x Parser/Print.hs Parser/Par.y Parser/Test.hs : Parser/Parser.cf 14 | bnfc --haskell -d Parser/Parser.cf 15 | 16 | %.hs : %.y 17 | happy --ghc --coerce --array --info $< 18 | 19 | %.hs : %.x 20 | alex --ghc $< 21 | 22 | Parser/Test : Parser/Test.hs Parser/ErrM.hs Parser/Lex.hs Parser/Par.hs Parser/Print.hs 23 | stack ghc -- --make $< -o $@ 24 | 25 | # Rules for cleaning generated files. 26 | 27 | clean : 28 | -rm -f Parser/*.hi Parser/*.o Parser/*.log Parser/*.aux Parser/*.dvi 29 | 30 | distclean : clean 31 | -rm -f Parser/Abs.hs Parser/Abs.hs.bak Parser/ComposOp.hs Parser/ComposOp.hs.bak Parser/Doc.txt Parser/Doc.txt.bak Parser/ErrM.hs Parser/ErrM.hs.bak Parser/Layout.hs Parser/Layout.hs.bak Parser/Lex.x Parser/Lex.x.bak Parser/Par.y Parser/Par.y.bak Parser/Print.hs Parser/Print.hs.bak Parser/SharedString.hs Parser/SharedString.hs.bak Parser/Skel.hs Parser/Skel.hs.bak Parser/Test.hs Parser/Test.hs.bak Parser/XML.hs Parser/XML.hs.bak Parser/AST.agda Parser/AST.agda.bak Parser/Parser.agda Parser/Parser.agda.bak Parser/IOLib.agda Parser/IOLib.agda.bak Parser/Main.agda Parser/Main.agda.bak Parser/Parser.dtd Parser/Parser.dtd.bak Parser/Test Parser/Lex.hs Parser/Par.hs Parser/Par.info Parser/ParData.hs Makefile 32 | -rmdir -p Parser/ 33 | 34 | # EOF 35 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import FunQ 6 | import Paths_qfunc ( version ) 7 | import Turtle 8 | import Data.Version ( showVersion ) 9 | import Data.Functor 10 | import qualified Interpreter.Run as Run 11 | import qualified Repl 12 | 13 | desc :: Description 14 | desc = "funQ - Functional Quantum Programming" 15 | 16 | -- | Parses an optional input file. 17 | parseInput :: Parser (Maybe (String, Maybe Int, Bool)) 18 | parseInput = optional $ (,,) <$> (encodeString <$> argPath "src" "The file to run") 19 | <*> optional (optInt "runs" 'r' "Runs the program n times") 20 | <*> switch "interactive" 'i' "Load file in interactive environment" 21 | 22 | -- | Option to show the funq version. 23 | parseVersion :: Parser (IO ()) 24 | parseVersion = switch "version" 'v' "Shows the interpreter version" $> ver 25 | where ver = putStrLn $ showVersion version 26 | 27 | -- | If a input file is provided execute it, 28 | -- else start the repl. 29 | parseMain :: Parser (IO ()) 30 | parseMain = withSrc <$> parseInput 31 | where withSrc Nothing = Repl.main 32 | withSrc (Just (path, _ , True)) = Repl.mainFile path 33 | withSrc (Just (path, Just runs, _)) = Run.rundistest path runs 34 | withSrc (Just (path, Nothing , _)) = Run.runIO path 35 | 36 | parser :: Parser (IO ()) 37 | parser = parseMain <|> parseVersion 38 | 39 | main :: IO () 40 | main = join (Turtle.options desc parser) 41 | -------------------------------------------------------------------------------- /examples/Teleport.hs: -------------------------------------------------------------------------------- 1 | -- | Quantum teleportation example 2 | module Teleport where 3 | 4 | import FunQ 5 | 6 | -- Example usage: 7 | -- 8 | -- >>> dist $ measure =<< teleport =<< hadamard =<< new 0 9 | -- Runs : 100 10 | -- |0> : 46.0 (46.0 %) 11 | -- |1> : 54.0 (54.0 %) 12 | -- 13 | -- >>> dist exampleTeleport 14 | -- Runs : 100 15 | -- |0> : 100.0 (100.0 %) 16 | -- |1> : 0.0 (0.0 %) 17 | 18 | -- | The quantum teleportation algorithm 19 | -- 1. create EPR pair (a,b) 20 | -- 2. perform bell measurment on (psi, a) 21 | -- 3. perform corrections on b according to the bell measurement 22 | teleport :: QBit -> QM QBit 23 | teleport psi = do 24 | a <- new 0 25 | b <- new 0 26 | hadamard a 27 | cnot (a,b) 28 | cnot (psi,a) 29 | hadamard psi 30 | m_psi <- measure psi 31 | m_a <- measure a 32 | pauliX b `controlbit` m_a 33 | pauliZ b `controlbit` m_psi 34 | return b 35 | 36 | -- | Create a qubit, teleport it, and measure it 37 | exampleTeleport :: QM Bit 38 | exampleTeleport = do 39 | q <- new 0 40 | hadamard q 41 | -- perform manipulations here 42 | q' <- teleport q 43 | -- the resulting distribution should be the same as 44 | -- for @q@ before the teleportation 45 | measure q' 46 | 47 | correction :: QBit -> (Bit, Bit) -> QM QBit 48 | correction q (x,y) = do 49 | pauliX q `controlbit` y 50 | pauliZ q `controlbit` x 51 | return q 52 | 53 | teleport' :: QBit -> QM QBit 54 | teleport' psi = do 55 | (a,b) <- bell (0,0) 56 | m <- bellMeasure (psi,a) 57 | correction b m 58 | -------------------------------------------------------------------------------- /Makefile.bak: -------------------------------------------------------------------------------- 1 | # Makefile generated by BNFC. 2 | 3 | # List of goals not corresponding to file names. 4 | 5 | .PHONY : all clean distclean 6 | 7 | # Default goal. 8 | 9 | bnfc : 10 | bnfc -d -m src/Parser/Parser.cf 11 | 12 | all : Parser/Test 13 | 14 | # Rules for building the parser. 15 | 16 | Parser/ErrM.hs Parser/Lex.x Parser/Print.hs Parser/Par.y Parser/Test.hs : src/Parser/Parser.cf 17 | bnfc --haskell -d src/Parser/Parser.cf 18 | 19 | %.hs : %.y 20 | happy --ghc --coerce --array --info $< 21 | 22 | %.hs : %.x 23 | alex --ghc $< 24 | 25 | Parser/Test : Parser/Test.hs Parser/ErrM.hs Parser/Lex.hs Parser/Par.hs Parser/Print.hs 26 | ghc --make $< -o $@ 27 | 28 | # Rules for cleaning generated files. 29 | 30 | clean : 31 | -rm -f Parser/*.hi Parser/*.o Parser/*.log Parser/*.aux Parser/*.dvi 32 | 33 | distclean : clean 34 | -rm -f Parser/Abs.hs Parser/Abs.hs.bak Parser/ComposOp.hs Parser/ComposOp.hs.bak Parser/Doc.txt Parser/Doc.txt.bak Parser/ErrM.hs Parser/ErrM.hs.bak Parser/Layout.hs Parser/Layout.hs.bak Parser/Lex.x Parser/Lex.x.bak Parser/Par.y Parser/Par.y.bak Parser/Print.hs Parser/Print.hs.bak Parser/SharedString.hs Parser/SharedString.hs.bak Parser/Skel.hs Parser/Skel.hs.bak Parser/Test.hs Parser/Test.hs.bak Parser/XML.hs Parser/XML.hs.bak Parser/AST.agda Parser/AST.agda.bak Parser/Parser.agda Parser/Parser.agda.bak Parser/IOLib.agda Parser/IOLib.agda.bak Parser/Main.agda Parser/Main.agda.bak Parser/Parser.dtd Parser/Parser.dtd.bak Parser/Test Parser/Lex.hs Parser/Par.hs Parser/Par.info Parser/ParData.hs Makefile 35 | -rmdir -p Parser/ 36 | 37 | # EOF 38 | -------------------------------------------------------------------------------- /src/Makefile.bak: -------------------------------------------------------------------------------- 1 | # Makefile generated by BNFC. 2 | 3 | GHC = stack ghc 4 | HAPPY = happy 5 | HAPPY_OPTS = --array --info --ghc --coerce 6 | ALEX = alex 7 | ALEX_OPTS = --ghc 8 | 9 | # List of goals not corresponding to file names. 10 | 11 | .PHONY : all clean distclean 12 | 13 | # Default goal. 14 | 15 | all : Parser/Test 16 | 17 | # Rules for building the parser. 18 | 19 | Parser/ErrM.hs Parser/Lex.x Parser/Print.hs Parser/Par.y Parser/Test.hs : Parser/Parser.cf 20 | bnfc --haskell -d Parser/Parser.cf 21 | 22 | %.hs : %.y 23 | happy --ghc --coerce --array --info $< 24 | 25 | %.hs : %.x 26 | alex --ghc $< 27 | 28 | Parser/Test : Parser/Test.hs Parser/ErrM.hs Parser/Lex.hs Parser/Par.hs Parser/Print.hs 29 | ghc --make $< -o $@ 30 | 31 | # Rules for cleaning generated files. 32 | 33 | clean : 34 | -rm -f Parser/*.hi Parser/*.o Parser/*.log Parser/*.aux Parser/*.dvi 35 | 36 | distclean : clean 37 | -rm -f Parser/Abs.hs Parser/Abs.hs.bak Parser/ComposOp.hs Parser/ComposOp.hs.bak Parser/Doc.txt Parser/Doc.txt.bak Parser/ErrM.hs Parser/ErrM.hs.bak Parser/Layout.hs Parser/Layout.hs.bak Parser/Lex.x Parser/Lex.x.bak Parser/Par.y Parser/Par.y.bak Parser/Print.hs Parser/Print.hs.bak Parser/SharedString.hs Parser/SharedString.hs.bak Parser/Skel.hs Parser/Skel.hs.bak Parser/Test.hs Parser/Test.hs.bak Parser/XML.hs Parser/XML.hs.bak Parser/AST.agda Parser/AST.agda.bak Parser/Parser.agda Parser/Parser.agda.bak Parser/IOLib.agda Parser/IOLib.agda.bak Parser/Main.agda Parser/Main.agda.bak Parser/Parser.dtd Parser/Parser.dtd.bak Parser/Test Parser/Lex.hs Parser/Par.hs Parser/Par.info Parser/ParData.hs Makefile 38 | -rmdir -p Parser/ 39 | 40 | # EOF 41 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: qfunc 2 | version: 0.9.1-beta 3 | github: "NicklasBoto/funQ" 4 | license: GPL-3 5 | author: 6 | - Nicklas Botö 7 | - Fabian Forslund 8 | - Matilda Blomqvist 9 | - Beata Burreau 10 | - Marcus Jörgensson 11 | - Joel Rudsberg 12 | maintainer: "qfunc@nicbot.xyz" 13 | copyright: "2021 Nicklas Botö" 14 | 15 | extra-source-files: 16 | - README.md 17 | - LICENSE 18 | 19 | # Metadata used when publishing your package 20 | # synopsis: Short description of your package 21 | # category: Web 22 | 23 | # To avoid duplicated efforts in documentation and dealing with the 24 | # complications of embedding Haddock markup inside cabal files, it is 25 | # common to point users to the README.md file. 26 | description: Please see the README on GitHub at 27 | 28 | dependencies: 29 | - base >= 4.7 && < 5 30 | - hmatrix 31 | - MonadRandom 32 | - bitvec 33 | - mtl 34 | - numbers 35 | - array 36 | - containers 37 | - haskeline 38 | - haskeline >= 0.8.0.0 39 | - repline >= 0.3.0.0 40 | - turtle 41 | - parsec 42 | - exceptions 43 | 44 | library: 45 | when: 46 | - condition: false 47 | other-modules: Paths_pkg 48 | source-dirs: 49 | - src 50 | 51 | executables: 52 | funq: 53 | main: Main.hs 54 | source-dirs: app 55 | ghc-options: 56 | - -threaded 57 | - -rtsopts 58 | - -with-rtsopts=-N 59 | dependencies: 60 | - qfunc 61 | 62 | tests: 63 | qfunc-test: 64 | main: Spec.hs 65 | source-dirs: test 66 | ghc-options: 67 | - -threaded 68 | - -rtsopts 69 | - -with-rtsopts=-N 70 | dependencies: 71 | - qfunc 72 | - QuickCheck 73 | -------------------------------------------------------------------------------- /src/Parser/Abs.hs: -------------------------------------------------------------------------------- 1 | -- Haskell data types for the abstract syntax. 2 | -- Generated by the BNF converter. 3 | 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Parser.Abs where 7 | 8 | import Prelude (Char, Double, Integer, String) 9 | import qualified Prelude as C (Eq, Ord, Show, Read) 10 | import qualified Data.String 11 | 12 | newtype FunVar = FunVar String 13 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 14 | 15 | newtype Var = Var String 16 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 17 | 18 | newtype GateIdent = GateIdent String 19 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 20 | 21 | newtype Lambda = Lambda String 22 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 23 | 24 | data Program = PDef [FunDec] 25 | deriving (C.Eq, C.Ord, C.Show, C.Read) 26 | 27 | data Term 28 | = TVar Var 29 | | TBit Bit 30 | | TGate Gate 31 | | TTup Tup 32 | | TStar 33 | | TApp Term Term 34 | | TIfEl Term Term Term 35 | | TLet LetVar [LetVar] Term Term 36 | | TLamb Lambda FunVar Type Term 37 | | TDolr Term Term 38 | deriving (C.Eq, C.Ord, C.Show, C.Read) 39 | 40 | data LetVar = LVar Var 41 | deriving (C.Eq, C.Ord, C.Show, C.Read) 42 | 43 | data Tup = Tuple Term [Term] 44 | deriving (C.Eq, C.Ord, C.Show, C.Read) 45 | 46 | data Bit = BBit Integer 47 | deriving (C.Eq, C.Ord, C.Show, C.Read) 48 | 49 | data FunDec = FDecl FunVar Type Function 50 | deriving (C.Eq, C.Ord, C.Show, C.Read) 51 | 52 | data Function = FDef Var [Arg] Term 53 | deriving (C.Eq, C.Ord, C.Show, C.Read) 54 | 55 | data Arg = FArg Var 56 | deriving (C.Eq, C.Ord, C.Show, C.Read) 57 | 58 | data Type 59 | = TypeBit 60 | | TypeQbit 61 | | TypeUnit 62 | | TypeDup Type 63 | | TypeTens Type Type 64 | | TypeFunc Type Type 65 | deriving (C.Eq, C.Ord, C.Show, C.Read) 66 | 67 | data Gate 68 | = GH 69 | | GX 70 | | GY 71 | | GZ 72 | | GI 73 | | GS 74 | | GT 75 | | GCNOT 76 | | GTOF 77 | | GSWP 78 | | GFRDK 79 | | GIdent GateIdent 80 | deriving (C.Eq, C.Ord, C.Show, C.Read) 81 | 82 | -------------------------------------------------------------------------------- /src/Parser/Abs.hs.bak: -------------------------------------------------------------------------------- 1 | -- Haskell data types for the abstract syntax. 2 | -- Generated by the BNF converter. 3 | 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Parser.Abs where 7 | 8 | import Prelude (Char, Double, Integer, String) 9 | import qualified Prelude as C (Eq, Ord, Show, Read) 10 | import qualified Data.String 11 | 12 | newtype FunVar = FunVar String 13 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 14 | 15 | newtype Var = Var String 16 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 17 | 18 | newtype GateIdent = GateIdent String 19 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 20 | 21 | newtype Lambda = Lambda String 22 | deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) 23 | 24 | data Program = PDef [FunDec] 25 | deriving (C.Eq, C.Ord, C.Show, C.Read) 26 | 27 | data Term 28 | = TVar Var 29 | | TBit Bit 30 | | TGate Gate 31 | | TTup Tup 32 | | TStar 33 | | TDolr Term Term 34 | | TApp Term Term 35 | | TIfEl Term Term Term 36 | | TLet LetVar [LetVar] Term Term 37 | | TLamb Lambda FunVar Type Term 38 | deriving (C.Eq, C.Ord, C.Show, C.Read) 39 | 40 | data LetVar = LVar Var 41 | deriving (C.Eq, C.Ord, C.Show, C.Read) 42 | 43 | data Tup = Tuple Term [Term] 44 | deriving (C.Eq, C.Ord, C.Show, C.Read) 45 | 46 | data Bit = BBit Integer 47 | deriving (C.Eq, C.Ord, C.Show, C.Read) 48 | 49 | data FunDec = FDecl FunVar Type Function 50 | deriving (C.Eq, C.Ord, C.Show, C.Read) 51 | 52 | data Function = FDef Var [Arg] Term 53 | deriving (C.Eq, C.Ord, C.Show, C.Read) 54 | 55 | data Arg = FArg Var 56 | deriving (C.Eq, C.Ord, C.Show, C.Read) 57 | 58 | data Type 59 | = TypeBit 60 | | TypeQbit 61 | | TypeUnit 62 | | TypeDup Type 63 | | TypeTens Type Type 64 | | TypeFunc Type Type 65 | deriving (C.Eq, C.Ord, C.Show, C.Read) 66 | 67 | data Gate 68 | = GH 69 | | GX 70 | | GY 71 | | GZ 72 | | GI 73 | | GS 74 | | GT 75 | | GCNOT 76 | | GTOF 77 | | GSWP 78 | | GFRDK 79 | | GIdent GateIdent 80 | deriving (C.Eq, C.Ord, C.Show, C.Read) 81 | 82 | -------------------------------------------------------------------------------- /src/FunQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-| 4 | Module : FunQ 5 | Description : Main library 6 | Stability : experimental 7 | 8 | Exports the language and simulator 9 | -} 10 | module FunQ 11 | ( -- * Core operations 12 | new 13 | , measure 14 | , ndist 15 | , dist 16 | , controlbit 17 | 18 | -- * Core types 19 | , QBit 20 | , Bit 21 | , QM 22 | 23 | -- * Gates 24 | , pauliX 25 | , pauliY 26 | , pauliZ 27 | , hadamard 28 | , phase 29 | , phasePi8 30 | , cnot 31 | , identity 32 | , swap 33 | , tdagger 34 | , fredkin 35 | , toffoli 36 | , urot 37 | , crot 38 | , qft 39 | , qftDagger 40 | , cphase 41 | , ccphase 42 | 43 | -- * Simulators 44 | , run 45 | , runDebug 46 | 47 | -- * Utils 48 | , bell 49 | , bellMeasure 50 | 51 | ) where 52 | 53 | import Control.Monad ( replicateM, mapM ) 54 | import Lib.QM ( QM, QBit, run, runDebug, io, checkState) 55 | import Lib.Core 56 | ( Bit, 57 | new, 58 | measure, 59 | controlbit, 60 | ndist, 61 | dist ) 62 | import Lib.Gates 63 | ( cnot, 64 | hadamard, 65 | identity, 66 | pauliX, 67 | pauliY, 68 | pauliZ, 69 | phase, 70 | phasePi8, 71 | swap, 72 | tdagger, 73 | fredkin, 74 | toffoli, 75 | urot, 76 | crot, 77 | qft, qftDagger, 78 | cphase, 79 | ccphase ) 80 | 81 | -- | Prepares bell state 82 | bell :: (Bit, Bit) -> QM (QBit, QBit) 83 | bell (a,b) = do 84 | qa <- new a 85 | qb <- new b 86 | hadamard qa 87 | cnot (qa, qb) 88 | 89 | -- | Performs bell measurement 90 | bellMeasure :: (QBit, QBit) -> QM (Bit, Bit) 91 | bellMeasure (x,y) = do 92 | cnot (x,y) 93 | hadamard x 94 | m_x <- measure x 95 | m_y <- measure y 96 | return (m_x, m_y) 97 | 98 | testt :: QM () 99 | testt = do 100 | q <- new 1 101 | q' <- new 1 102 | checkState 103 | cphase (q,q') (1/3) 104 | checkState -------------------------------------------------------------------------------- /src/Parser/Test.hs: -------------------------------------------------------------------------------- 1 | -- Program to test parser, automatically generated by BNF Converter. 2 | 3 | module Main where 4 | 5 | import System.Environment ( getArgs, getProgName ) 6 | import System.Exit ( exitFailure, exitSuccess ) 7 | import Control.Monad ( when ) 8 | 9 | import Parser.Lex ( Token ) 10 | import Parser.Par ( pProgram, myLexer ) 11 | import Parser.Skel () 12 | import Parser.Print ( Print, printTree ) 13 | import Parser.Abs () 14 | 15 | type Err = Either String 16 | type ParseFun a = [Token] -> Err a 17 | 18 | myLLexer = myLexer 19 | 20 | type Verbosity = Int 21 | 22 | putStrV :: Verbosity -> String -> IO () 23 | putStrV v s = when (v > 1) $ putStrLn s 24 | 25 | runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () 26 | runFile v p f = putStrLn f >> readFile f >>= run v p 27 | 28 | run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () 29 | run v p s = case p ts of 30 | Left s -> do 31 | putStrLn "\nParse Failed...\n" 32 | putStrV v "Tokens:" 33 | putStrV v $ show ts 34 | putStrLn s 35 | exitFailure 36 | Right tree -> do 37 | putStrLn "\nParse Successful!" 38 | showTree v tree 39 | 40 | exitSuccess 41 | where 42 | ts = myLLexer s 43 | 44 | 45 | showTree :: (Show a, Print a) => Int -> a -> IO () 46 | showTree v tree 47 | = do 48 | putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree 49 | putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree 50 | 51 | usage :: IO () 52 | usage = do 53 | putStrLn $ unlines 54 | [ "usage: Call with one of the following argument combinations:" 55 | , " --help Display this help message." 56 | , " (no arguments) Parse stdin verbosely." 57 | , " (files) Parse content of files verbosely." 58 | , " -s (files) Silent mode. Parse content of files silently." 59 | ] 60 | exitFailure 61 | 62 | main :: IO () 63 | main = do 64 | args <- getArgs 65 | case args of 66 | ["--help"] -> usage 67 | [] -> getContents >>= run 2 pProgram 68 | "-s":fs -> mapM_ (runFile 0 pProgram) fs 69 | fs -> mapM_ (runFile 2 pProgram) fs 70 | 71 | -------------------------------------------------------------------------------- /src/Parser/Test.hs.bak: -------------------------------------------------------------------------------- 1 | -- Program to test parser, automatically generated by BNF Converter. 2 | 3 | module Parser.Test where 4 | 5 | import System.Environment ( getArgs, getProgName ) 6 | import System.Exit ( exitFailure, exitSuccess ) 7 | import Control.Monad ( when ) 8 | 9 | import Parser.Lex ( Token ) 10 | import Parser.Par ( pProgram, myLexer ) 11 | import Parser.Skel () 12 | import Parser.Print ( Print, printTree ) 13 | import Parser.Abs () 14 | 15 | type Err = Either String 16 | type ParseFun a = [Token] -> Err a 17 | 18 | myLLexer = myLexer 19 | 20 | type Verbosity = Int 21 | 22 | putStrV :: Verbosity -> String -> IO () 23 | putStrV v s = when (v > 1) $ putStrLn s 24 | 25 | runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () 26 | runFile v p f = putStrLn f >> readFile f >>= run v p 27 | 28 | run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () 29 | run v p s = case p ts of 30 | Left s -> do 31 | putStrLn "\nParse Failed...\n" 32 | putStrV v "Tokens:" 33 | putStrV v $ show ts 34 | putStrLn s 35 | exitFailure 36 | Right tree -> do 37 | putStrLn "\nParse Successful!" 38 | showTree v tree 39 | 40 | exitSuccess 41 | where 42 | ts = myLLexer s 43 | 44 | 45 | showTree :: (Show a, Print a) => Int -> a -> IO () 46 | showTree v tree 47 | = do 48 | putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree 49 | putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree 50 | 51 | usage :: IO () 52 | usage = do 53 | putStrLn $ unlines 54 | [ "usage: Call with one of the following argument combinations:" 55 | , " --help Display this help message." 56 | , " (no arguments) Parse stdin verbosely." 57 | , " (files) Parse content of files verbosely." 58 | , " -s (files) Silent mode. Parse content of files silently." 59 | ] 60 | exitFailure 61 | 62 | main :: IO () 63 | main = do 64 | args <- getArgs 65 | case args of 66 | ["--help"] -> usage 67 | [] -> getContents >>= run 2 pProgram 68 | "-s":fs -> mapM_ (runFile 0 pProgram) fs 69 | fs -> mapM_ (runFile 2 pProgram) fs 70 | 71 | -------------------------------------------------------------------------------- /test/InterpreterTests.hs: -------------------------------------------------------------------------------- 1 | module InterpreterTests( 2 | runTests, 3 | ) where 4 | import Control.Monad.Except (runExceptT, liftIO) 5 | import Interpreter.Run 6 | 7 | runTests :: IO Bool 8 | runTests = do 9 | -- runExceptT tar en exceptT-transformerad monad och kör den, tar ur den inre monaden ur exceptT 10 | -- och returnar Either left right 11 | res <- runExceptT (foldr runTest (pure 0) tests) 12 | case res of 13 | Left err -> putStrLn ("Interpreter test failed with error: " ++ show err) >> return False 14 | Right correct -> putStrLn ("Succesful tests for interpreter " ++ show correct ++ "/" ++ show (length tests)) >> return True 15 | 16 | runTest :: (String, String) -> Run Int -> Run Int 17 | runTest (fileName, expectedValue) b = do 18 | liftIO . print $ "Testing file " ++ show fileName 19 | res <- readfile (testPath fileName) >>= run 20 | acc <- b 21 | if show res == expectedValue 22 | then do 23 | return $ acc + 1 24 | else do 25 | liftIO $ putStrLn $ "Got " ++ show res ++ " but expected " ++ show expectedValue 26 | return acc 27 | 28 | testPath :: String -> String 29 | testPath testName = "test/interpreter-test-suite/" ++ testName 30 | 31 | tests :: [(FilePath, String)] 32 | tests = 33 | [ 34 | ("cnot.fq", "0"), 35 | ("equals.fq", "1"), 36 | ("higher-order-function.fq","⟨0,1⟩"), 37 | ("id.fq", "1"), 38 | ("let-tup-q.fq", "0"), 39 | ("let-tup.fq", "0"), 40 | ("partial-app-cnot.fq", "1"), 41 | ("partial-app-comp.fq", "0"), 42 | ("partial-app-new.fq", "1"), 43 | ("partial-app-meas.fq", "0"), 44 | ("pauliX.fq", "1"), 45 | ("pauliY.fq", "1"), 46 | ("pauliZ.fq", "0"), 47 | ("phase.fq", "0"), 48 | ("plus.fq", "0"), 49 | ("second-q.fq", "0"), 50 | ("second.fq", "1"), 51 | ("seventh.fq", "0"), 52 | ("swap.fq", "1"), 53 | ("swapTwice.fq", "1"), 54 | ("third.fq", "1"), 55 | ("teleport.fq", "1"), 56 | ("nested-let.fq", "0"), 57 | ("deutsch.fq", "1"), 58 | ("qft5.fq", "⟨1,⟨0,⟨1,⟨0,1⟩⟩⟩⟩"), 59 | ("qft4.fq", "⟨0,⟨1,⟨0,1⟩⟩⟩"), 60 | ("qft3.fq", "⟨0,⟨1,0⟩⟩"), 61 | ("qft2.fq", "⟨0,1⟩"), 62 | ("qft1.fq", "0"), 63 | ("tdagger.fq", "1") 64 | ] 65 | 66 | -------------------------------------------------------------------------------- /test/QStateTests.hs: -------------------------------------------------------------------------------- 1 | module QStateTests ( 2 | runTests 3 | ) where 4 | 5 | import TestCore 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Monadic as TM 8 | import Numeric.LinearAlgebra as LA 9 | 10 | runTests :: IO Bool 11 | runTests = do 12 | putStrLn "QuickCheck tests qstate size keeps good norm after applying hadamard gate" 13 | b_h <- quickCheckResult $ prop_hadamard 8 14 | 15 | putStrLn "QuickCheck tests the norm of generated QStates, of 1 < lengths < n , is one" 16 | b_n <- quickCheckResult $ prop_norm 8 17 | 18 | return $ all isSuccess [b_n, b_h] 19 | 20 | -- | Checks that the QState of arbitrary size after a hadamard gate is applied keeps a good norm and 21 | -- that the QState vector only contains two amplitudes at 1/sqrt(2). 22 | -- This function in particular may kill your computer if it's let to run without max bounds. 23 | prop_hadamard :: Int -> Property 24 | prop_hadamard n 25 | | n > maxAllowedN = errorWithoutStackTrace maxExceededErrorMsg 26 | | otherwise = monadicIO $ do 27 | m <- pick $ choose (1,n) 28 | TM.forAllM (genBits n) $ assertive m 29 | where assertive :: Int -> [Bit] -> PropertyM IO () 30 | assertive m bs = do 31 | qs@(QState s) <- qrun $ mapM new bs >>= \x -> hadamard (x !! div (length bs-1) m) >> get 32 | assert $ goodNorm qs && length (filter ((1/sqrt 2) ~=) (toList s)) == 2 33 | 34 | -- | Checks that the norm of generated QStates, of 1 < lengths < n , is one 35 | prop_norm :: Int -> Property 36 | prop_norm n 37 | | n > maxAllowedN = errorWithoutStackTrace maxExceededErrorMsg 38 | | otherwise = monadicIO $ 39 | TM.forAllM (genBits n) assertive 40 | where assertive :: [Bit] -> PropertyM IO () 41 | assertive bs = do 42 | qs <- qrun $ mapM_ new bs >> get 43 | assert $ goodNorm qs 44 | 45 | -- | Maximum allowed length of QState 46 | maxAllowedN :: Int 47 | maxAllowedN = 10 48 | 49 | -- | The error message returned when maxAllowedN is exceeded 50 | maxExceededErrorMsg :: String 51 | maxExceededErrorMsg = "your computer almost just died. either you forgot to input a value, or you want to raise the value for allowed inputs" 52 | 53 | -- | Checks that the norm of the given QState is 1 54 | goodNorm :: QState -> Bool 55 | goodNorm (QState s) = (~=) (norm_2 s :+ 0) 1 -------------------------------------------------------------------------------- /src/Parser/ErrM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if __GLASGOW_HASKELL__ >= 708 4 | --------------------------------------------------------------------------- 5 | -- Pattern synonyms exist since ghc 7.8. 6 | 7 | -- | BNF Converter: Error Monad. 8 | -- 9 | -- Module for backwards compatibility. 10 | -- 11 | -- The generated parser now uses @'Either' String@ as error monad. 12 | -- This module defines a type synonym 'Err' and pattern synonyms 13 | -- 'Bad' and 'Ok' for 'Left' and 'Right'. 14 | 15 | {-# LANGUAGE PatternSynonyms #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | {-# LANGUAGE TypeSynonymInstances #-} 18 | 19 | module Parser.ErrM where 20 | 21 | import Control.Monad (MonadPlus(..)) 22 | import Control.Applicative (Alternative(..)) 23 | 24 | -- | Error monad with 'String' error messages. 25 | type Err = Either String 26 | 27 | pattern Bad msg = Left msg 28 | pattern Ok a = Right a 29 | 30 | #if __GLASGOW_HASKELL__ >= 808 31 | instance MonadFail Err where 32 | fail = Bad 33 | #endif 34 | 35 | instance Alternative Err where 36 | empty = Left "Err.empty" 37 | (<|>) Left{} = id 38 | (<|>) x@Right{} = const x 39 | 40 | instance MonadPlus Err where 41 | mzero = empty 42 | mplus = (<|>) 43 | 44 | #else 45 | --------------------------------------------------------------------------- 46 | -- ghc 7.6 and before: use old definition as data type. 47 | 48 | -- | BNF Converter: Error Monad 49 | 50 | -- Copyright (C) 2004 Author: Aarne Ranta 51 | -- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. 52 | 53 | module Parser.ErrM where 54 | 55 | -- the Error monad: like Maybe type with error msgs 56 | 57 | import Control.Applicative (Applicative(..), Alternative(..)) 58 | import Control.Monad (MonadPlus(..), liftM) 59 | 60 | data Err a = Ok a | Bad String 61 | deriving (Read, Show, Eq, Ord) 62 | 63 | instance Monad Err where 64 | return = Ok 65 | Ok a >>= f = f a 66 | Bad s >>= _ = Bad s 67 | 68 | instance Applicative Err where 69 | pure = Ok 70 | (Bad s) <*> _ = Bad s 71 | (Ok f) <*> o = liftM f o 72 | 73 | instance Functor Err where 74 | fmap = liftM 75 | 76 | instance MonadPlus Err where 77 | mzero = Bad "Err.mzero" 78 | mplus (Bad _) y = y 79 | mplus x _ = x 80 | 81 | instance Alternative Err where 82 | empty = mzero 83 | (<|>) = mplus 84 | 85 | #endif 86 | -------------------------------------------------------------------------------- /src/Parser/Parser.cf: -------------------------------------------------------------------------------- 1 | PDef. Program ::= [FunDec] ; 2 | 3 | --- Terms --- 4 | TVar . Term3 ::= Var ; 5 | TBit . Term3 ::= Bit ; 6 | TGate . Term3 ::= Gate ; 7 | TTup . Term3 ::= Tup ; 8 | TStar . Term3 ::= "*" ; 9 | TApp . Term2 ::= Term2 Term3 ; 10 | TIfEl . Term1 ::= "if" Term "then" Term "else" Term ; 11 | TLet . Term1 ::= "let" "(" LetVar "," [LetVar] ")" "=" Term "in" Term ; 12 | TLamb . Term1 ::= Lambda FunVar Type "." Term ; 13 | TDolr . Term1 ::= Term2 "$" Term1 ; 14 | coercions Term 3; 15 | 16 | LVar . LetVar ::= Var; 17 | separator nonempty LetVar ","; 18 | 19 | Tuple. Tup ::= "(" Term "," [Term] ")" ; 20 | separator nonempty Term ","; 21 | 22 | --- Bits --- 23 | BBit. Bit ::= Integer; 24 | 25 | --- Function declaration --- 26 | FDecl. FunDec ::= FunVar Type Function; 27 | terminator FunDec ""; 28 | 29 | FDef. Function ::= Var [Arg] "=" Term; 30 | 31 | FArg. Arg ::= Var ; 32 | separator Arg " "; 33 | 34 | comment "--" ; 35 | comment "{-" "-}"; 36 | 37 | token FunVar (lower (letter | digit | '_' | '\'')* (' ')* ':') ; 38 | 39 | --- Var --- 40 | token Var (lower (letter | digit | '_' | '\'')*) ; 41 | 42 | --- GateIdent --- 43 | token GateIdent (upper (upper | digit)*) ; 44 | 45 | --- Lambda token --- 46 | -- token Lambda char (0xBB) ; 47 | token Lambda '\\' ; 48 | 49 | --- Type --- 50 | TypeBit . Type2 ::= "Bit" ; 51 | TypeQbit . Type2 ::= "QBit" ; 52 | TypeUnit . Type2 ::= "T" ; 53 | TypeDup . Type2 ::= "!" Type2 ; 54 | TypeTens . Type1 ::= Type2 "><" Type1 ; 55 | TypeFunc . Type1 ::= Type2 "-o" Type1 ; 56 | coercions Type 2; 57 | 58 | --- Gates --- 59 | GH . Gate ::= "H" ; 60 | GX . Gate ::= "X" ; 61 | GY . Gate ::= "Y" ; 62 | GZ . Gate ::= "Z" ; 63 | GI . Gate ::= "I" ; 64 | GS . Gate ::= "S" ; 65 | GT . Gate ::= "T" ; 66 | GCNOT . Gate ::= "CNOT" ; 67 | GTOF . Gate ::= "TOFFOLI" ; 68 | GSWP . Gate ::= "SWAP" ; 69 | GFRDK . Gate ::= "FREDKIN" ; 70 | GIdent . Gate ::= GateIdent ; -------------------------------------------------------------------------------- /test/interpreter-test-suite/qpe.fq: -------------------------------------------------------------------------------- 1 | init2 : QBit >< QBit >< QBit 2 | init2 = (H (new 0), H (new 0), new 1) 3 | 4 | init3 : QBit >< QBit >< QBit >< QBit 5 | init3 = (H (new 0), H (new 0), H (new 0), new 1) 6 | 7 | init4 : QBit >< QBit >< QBit >< QBit >< QBit 8 | init4 = (H (new 0), H (new 0), H (new 0), H (new 0), new 1) 9 | 10 | 11 | 12 | applyU2 : QBit >< QBit 13 | applyU2 = let (q0,q1,q2) = init2 in 14 | let (q11,q21) = CR4 (q1,q2) in 15 | let (q01,q22) = CR4 (CR4 (q0,q21)) in 16 | (q01,q11) 17 | 18 | applyU3 : QBit >< QBit >< QBit 19 | applyU3 = let (q0,q1,q2,q3) = init3 in 20 | let (q21,q31) = CR4 (q2,q3) in 21 | let (q11,q32) = CR4 (CR4 (q1,q31)) in 22 | let (q01,q33) = CR4 (CR4 (CR4 (CR4 (q0,q32)))) in 23 | (q01,q11,q21) 24 | 25 | applyU4 : QBit >< QBit >< QBit >< QBit 26 | applyU4 = let (q0,q1,q2,q3,q4) = init4 in 27 | let (q31,q41) = CR4 (q3,q4) in 28 | let (q21,q42) = CR4 (CR4 (q2,q41)) in 29 | let (q11,q43) = CR4 (CR4 (CR4 (CR4 (q1,q42)))) in 30 | let (q01,q44) = CR4 (CR4 (CR4 (CR4 (CR4 (CR4 (CR4 (CR4 (q0,q43)))))))) in 31 | (q01,q11,q21,q31) 32 | 33 | 34 | meas2 : (QBit >< QBit) -o (Bit >< Bit) 35 | meas2 q = let (a,b) = q in (meas a, meas b) 36 | 37 | meas3 : (QBit >< QBit >< QBit) -o (Bit >< Bit >< Bit) 38 | meas3 q = let (a,b,c) = q in (meas a,meas b,meas c) 39 | 40 | meas4 : (QBit >< QBit >< QBit >< QBit) -o (Bit >< Bit >< Bit >< Bit) 41 | meas4 q = let (a,b,c,d) = q in (meas a,meas b,meas c,meas d) 42 | 43 | main : Bit >< Bit >< Bit >< Bit 44 | main = meas4 (QFTI applyU4) 45 | 46 | -- qft : (QBit >< QBit >< QBit) -o (QBit >< QBit >< QBit) 47 | -- qft q = let (q1,q2,q3) = q in 48 | -- let (q21,q11) = CR4 (q2,H q1) in 49 | -- let (q31,q12) = CR4 (q3,q11) in 50 | -- let (q32,q22) = CR4 (q31,H q21) in 51 | -- (H q32, q22, q12) 52 | 53 | -- qftdagger : (QBit >< QBit >< QBit) -o (QBit >< QBit >< QBit) 54 | -- qftdagger q = let (q1,q2,q3) = q in 55 | -- let (q11,q31) = SWAP (q1,q3) in 56 | -- let (q32,q21) = CR4D (H q31,q2) in 57 | -- let (q33,q12) = CR4D (q32,q11) in 58 | -- let (q22,q13) = CR4D (H q21,q12) in 59 | -- (H q13,q22,q33) 60 | -------------------------------------------------------------------------------- /src/Lib/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | {-| 6 | Module : Core 7 | Description : Core language 8 | Stability : experimental 9 | 10 | The core language operations. 11 | -} 12 | module Lib.Core ( 13 | -- * QBit manipulation 14 | new 15 | , measure 16 | 17 | -- * Control functions 18 | , controlbit 19 | , (===) 20 | 21 | -- * Distribution functions 22 | , dist 23 | , ndist 24 | 25 | -- * Bit 26 | , Data.Bit.Bit 27 | ) where 28 | 29 | import Lib.QM ( QM, QBit(Ptr), io, put, get, modify, run, getState ) 30 | import Lib.Internal.Core ( findQbitProb1, remImpossibleStates, Prob, appendState, newVector, rngQbit ) 31 | import Data.Bit ( Bit ) 32 | import Control.Monad ( replicateM ) 33 | 34 | -- | Create new `QBit` from a bit. 35 | -- maps \(0 \mapsto |0>\) and \(1 \mapsto |1>\) 36 | new :: Bit -> QM QBit 37 | new x = do 38 | (_,size) <- getState 39 | modify $ appendState (newVector x) 40 | return $ Ptr size 41 | 42 | -- | Performs a measurement operation, collapsing a `QBit` to a `Bit`. 43 | -- The qubit will still exist in the quantum state, but be collapsed. 44 | -- 45 | -- Finds qubit probability to collapse to a zero and one. 46 | -- Uses random number generator to "measure it" to a zero or one. 47 | -- Updates quantum state to remove impossible states, and normalizes it so probabilites sum to one. 48 | measure :: QBit -> QM Bit 49 | measure qbit = do 50 | state <- get 51 | let p1 = findQbitProb1 qbit state 52 | bit <- io $ rngQbit p1 -- Need to use io for randomness 53 | let newState = remImpossibleStates state qbit bit 54 | put newState 55 | return bit 56 | 57 | -- | Sets a classical bit as the controlbit for a quantum gate. 58 | -- Making it run only when the classical bit is equal to one. 59 | controlbit :: QM a -> Bit -> QM () 60 | controlbit m 1 = m >> return () 61 | controlbit m 0 = return () 62 | 63 | -- | Synonym for controlbit 64 | (===) :: QM a -> Bit -> QM () 65 | (===) = controlbit 66 | 67 | -- | Run a quantum program producing a single bit @reps@ times 68 | -- and print the results 69 | ndist :: Int -> QM Bit -> IO () 70 | ndist reps meas = do 71 | putStrLn $ "Runs : " ++ show reps 72 | ms <- replicateM reps (run meas) 73 | let is = map fromIntegral ms 74 | let ones = sum is :: Double 75 | let zeros = fromIntegral reps - ones 76 | let pones = 100 * (ones / fromIntegral reps) 77 | let pzeros = 100 - pones 78 | putStrLn $ "|0> : " ++ show zeros ++ " (" ++ show pzeros ++ " %)" 79 | putStrLn $ "|1> : " ++ show ones ++ " (" ++ show pones ++ " %)" 80 | 81 | -- | Print results from a 100 runs of a program 82 | dist :: QM Bit -> IO () 83 | dist = ndist 100 84 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/18.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | extra-deps: 45 | - repline-0.4.0.0@sha256:3324479e497d27c40c3d4762bffc52058f9921621d20d2947dcf9a554b94cd0d,2253 46 | - haskeline-0.8.1.1@sha256:21c0d6bd9f36a8b0cfbceab30820f4fe4ac72535c4d2cdf217123d816a4e494e,5818 47 | # Override default flag values for local packages and extra-deps 48 | # flags: {} 49 | 50 | ghc-options: 51 | "$everything": -O2 -funfolding-use-threshold=16 -fexcess-precision -optc-ffast-math -optc-O3 52 | 53 | rebuild-ghc-options: true 54 | 55 | # Extra package databases containing global packages 56 | # extra-package-dbs: [] 57 | 58 | # Control whether we use the GHC we find on the path 59 | # system-ghc: true 60 | # 61 | # Require a specific version of stack, using version ranges 62 | # require-stack-version: -any # Default 63 | # require-stack-version: ">=2.3" 64 | # 65 | # Override the architecture used by stack, especially useful on Windows 66 | # arch: i386 67 | # arch: x86_64 68 | # 69 | # Extra directories used by stack for building 70 | # extra-include-dirs: [/path/to/dir] 71 | # extra-lib-dirs: [/path/to/dir] 72 | # 73 | # Allow a newer minor version of GHC than the snapshot specifies 74 | # compiler-check: newer-minor 75 | -------------------------------------------------------------------------------- /src/Parser/Skel.hs: -------------------------------------------------------------------------------- 1 | -- Haskell module generated by the BNF converter 2 | 3 | module Parser.Skel where 4 | 5 | import qualified Parser.Abs 6 | 7 | type Err = Either String 8 | type Result = Err String 9 | 10 | failure :: Show a => a -> Result 11 | failure x = Left $ "Undefined case: " ++ show x 12 | 13 | transFunVar :: Parser.Abs.FunVar -> Result 14 | transFunVar x = case x of 15 | Parser.Abs.FunVar string -> failure x 16 | transVar :: Parser.Abs.Var -> Result 17 | transVar x = case x of 18 | Parser.Abs.Var string -> failure x 19 | transGateIdent :: Parser.Abs.GateIdent -> Result 20 | transGateIdent x = case x of 21 | Parser.Abs.GateIdent string -> failure x 22 | transLambda :: Parser.Abs.Lambda -> Result 23 | transLambda x = case x of 24 | Parser.Abs.Lambda string -> failure x 25 | transProgram :: Parser.Abs.Program -> Result 26 | transProgram x = case x of 27 | Parser.Abs.PDef fundecs -> failure x 28 | transTerm :: Parser.Abs.Term -> Result 29 | transTerm x = case x of 30 | Parser.Abs.TVar var -> failure x 31 | Parser.Abs.TBit bit -> failure x 32 | Parser.Abs.TGate gate -> failure x 33 | Parser.Abs.TTup tup -> failure x 34 | Parser.Abs.TStar -> failure x 35 | Parser.Abs.TApp term1 term2 -> failure x 36 | Parser.Abs.TIfEl term1 term2 term3 -> failure x 37 | Parser.Abs.TLet letvar letvars term1 term2 -> failure x 38 | Parser.Abs.TLamb lambda funvar type_ term -> failure x 39 | Parser.Abs.TDolr term1 term2 -> failure x 40 | transLetVar :: Parser.Abs.LetVar -> Result 41 | transLetVar x = case x of 42 | Parser.Abs.LVar var -> failure x 43 | transTup :: Parser.Abs.Tup -> Result 44 | transTup x = case x of 45 | Parser.Abs.Tuple term terms -> failure x 46 | transBit :: Parser.Abs.Bit -> Result 47 | transBit x = case x of 48 | Parser.Abs.BBit integer -> failure x 49 | transFunDec :: Parser.Abs.FunDec -> Result 50 | transFunDec x = case x of 51 | Parser.Abs.FDecl funvar type_ function -> failure x 52 | transFunction :: Parser.Abs.Function -> Result 53 | transFunction x = case x of 54 | Parser.Abs.FDef var args term -> failure x 55 | transArg :: Parser.Abs.Arg -> Result 56 | transArg x = case x of 57 | Parser.Abs.FArg var -> failure x 58 | transType :: Parser.Abs.Type -> Result 59 | transType x = case x of 60 | Parser.Abs.TypeBit -> failure x 61 | Parser.Abs.TypeQbit -> failure x 62 | Parser.Abs.TypeUnit -> failure x 63 | Parser.Abs.TypeDup type_ -> failure x 64 | Parser.Abs.TypeTens type_1 type_2 -> failure x 65 | Parser.Abs.TypeFunc type_1 type_2 -> failure x 66 | transGate :: Parser.Abs.Gate -> Result 67 | transGate x = case x of 68 | Parser.Abs.GH -> failure x 69 | Parser.Abs.GX -> failure x 70 | Parser.Abs.GY -> failure x 71 | Parser.Abs.GZ -> failure x 72 | Parser.Abs.GI -> failure x 73 | Parser.Abs.GS -> failure x 74 | Parser.Abs.GT -> failure x 75 | Parser.Abs.GCNOT -> failure x 76 | Parser.Abs.GTOF -> failure x 77 | Parser.Abs.GSWP -> failure x 78 | Parser.Abs.GFRDK -> failure x 79 | Parser.Abs.GIdent gateident -> failure x 80 | 81 | -------------------------------------------------------------------------------- /src/Parser/Skel.hs.bak: -------------------------------------------------------------------------------- 1 | -- Haskell module generated by the BNF converter 2 | 3 | module Parser.Skel where 4 | 5 | import qualified Parser.Abs 6 | 7 | type Err = Either String 8 | type Result = Err String 9 | 10 | failure :: Show a => a -> Result 11 | failure x = Left $ "Undefined case: " ++ show x 12 | 13 | transFunVar :: Parser.Abs.FunVar -> Result 14 | transFunVar x = case x of 15 | Parser.Abs.FunVar string -> failure x 16 | transVar :: Parser.Abs.Var -> Result 17 | transVar x = case x of 18 | Parser.Abs.Var string -> failure x 19 | transGateIdent :: Parser.Abs.GateIdent -> Result 20 | transGateIdent x = case x of 21 | Parser.Abs.GateIdent string -> failure x 22 | transLambda :: Parser.Abs.Lambda -> Result 23 | transLambda x = case x of 24 | Parser.Abs.Lambda string -> failure x 25 | transProgram :: Parser.Abs.Program -> Result 26 | transProgram x = case x of 27 | Parser.Abs.PDef fundecs -> failure x 28 | transTerm :: Parser.Abs.Term -> Result 29 | transTerm x = case x of 30 | Parser.Abs.TVar var -> failure x 31 | Parser.Abs.TBit bit -> failure x 32 | Parser.Abs.TGate gate -> failure x 33 | Parser.Abs.TTup tup -> failure x 34 | Parser.Abs.TStar -> failure x 35 | Parser.Abs.TDolr term1 term2 -> failure x 36 | Parser.Abs.TApp term1 term2 -> failure x 37 | Parser.Abs.TIfEl term1 term2 term3 -> failure x 38 | Parser.Abs.TLet letvar letvars term1 term2 -> failure x 39 | Parser.Abs.TLamb lambda funvar type_ term -> failure x 40 | transLetVar :: Parser.Abs.LetVar -> Result 41 | transLetVar x = case x of 42 | Parser.Abs.LVar var -> failure x 43 | transTup :: Parser.Abs.Tup -> Result 44 | transTup x = case x of 45 | Parser.Abs.Tuple term terms -> failure x 46 | transBit :: Parser.Abs.Bit -> Result 47 | transBit x = case x of 48 | Parser.Abs.BBit integer -> failure x 49 | transFunDec :: Parser.Abs.FunDec -> Result 50 | transFunDec x = case x of 51 | Parser.Abs.FDecl funvar type_ function -> failure x 52 | transFunction :: Parser.Abs.Function -> Result 53 | transFunction x = case x of 54 | Parser.Abs.FDef var args term -> failure x 55 | transArg :: Parser.Abs.Arg -> Result 56 | transArg x = case x of 57 | Parser.Abs.FArg var -> failure x 58 | transType :: Parser.Abs.Type -> Result 59 | transType x = case x of 60 | Parser.Abs.TypeBit -> failure x 61 | Parser.Abs.TypeQbit -> failure x 62 | Parser.Abs.TypeUnit -> failure x 63 | Parser.Abs.TypeDup type_ -> failure x 64 | Parser.Abs.TypeTens type_1 type_2 -> failure x 65 | Parser.Abs.TypeFunc type_1 type_2 -> failure x 66 | transGate :: Parser.Abs.Gate -> Result 67 | transGate x = case x of 68 | Parser.Abs.GH -> failure x 69 | Parser.Abs.GX -> failure x 70 | Parser.Abs.GY -> failure x 71 | Parser.Abs.GZ -> failure x 72 | Parser.Abs.GI -> failure x 73 | Parser.Abs.GS -> failure x 74 | Parser.Abs.GT -> failure x 75 | Parser.Abs.GCNOT -> failure x 76 | Parser.Abs.GTOF -> failure x 77 | Parser.Abs.GSWP -> failure x 78 | Parser.Abs.GFRDK -> failure x 79 | Parser.Abs.GIdent gateident -> failure x 80 | 81 | -------------------------------------------------------------------------------- /legacy/QOps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE LiberalTypeSynonyms #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE OverloadedLists #-} 7 | {-# LANGUAGE ConstraintKinds #-} 8 | {-# LANGUAGE BlockArguments #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE DerivingVia #-} 12 | {-# LANGUAGE Rank2Types #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 17 | {-# OPTIONS_HADDOCK not-home #-} 18 | 19 | {-| 20 | Module : QData 21 | Description : qfunc datatypes 22 | Stability : experimental 23 | 24 | The basic language operations. 25 | -} 26 | module QOps 27 | ( -- * Q/Bit conversions 28 | new 29 | , measure 30 | ) where 31 | 32 | import Numeric.LinearAlgebra.Static as V hiding ( outer ) 33 | import Numeric.LinearAlgebra ( flatten, outer, kronecker, ident, toList, asColumn, asRow, magnitude ) 34 | import qualified Numeric.LinearAlgebra as LA ( (><), fromList ) 35 | import GHC.TypeLits ( Nat, type (+), type (^), KnownNat, natVal ) 36 | import qualified Data.Bit as B ( Bit(..) ) 37 | import Data.Proxy ( Proxy(..) ) 38 | import Prelude 39 | import Control.Monad.Random as Rand ( fromList, evalRandIO ) 40 | import QData ( Bit, QBit(..) ) 41 | 42 | -- | Constructs new qubits 43 | new :: Bit 1 -> QBit 1 44 | new 0 = Q $ V.fromList [ 1 45 | , 0 ] 46 | 47 | new 1 = Q $ V.fromList [ 0 48 | , 1 ] 49 | 50 | -- | Collapses a qubit state (of size 1) to a single bit 51 | measure :: KnownNat n => QBit n -> IO Int 52 | measure = measureI 53 | 54 | -- | Measurement using list operations 55 | measureI :: KnownNat n => QBit n -> IO Int 56 | measureI = evalRandIO 57 | . Rand.fromList 58 | . zip [0..] 59 | . map (toRational . (^2) . magnitude) 60 | . toList 61 | . extract 62 | . getState 63 | 64 | -- | Measurement using list operations 65 | measureN :: QBit 1 -> IO (Bit 1) 66 | measureN = evalRandIO 67 | . Rand.fromList 68 | . zip [0,1] 69 | . map (toRational . (^2) . magnitude) 70 | . toList 71 | . extract 72 | . getState 73 | 74 | -- | Measurement using vector operations 75 | measureLA :: QBit 1 -> IO (Bit 1) 76 | measureLA (Q q) = (evalRandIO 77 | . Rand.fromList 78 | . zip [0,1] 79 | . map toRational) 80 | [prob (LA.fromList [1,0]), prob (LA.fromList [0,1])] 81 | where projOp b = kronecker (asColumn b) (asRow b) 82 | prob b = ((^2) . norm_0) $ kronecker (projOp b) ((asColumn . extract) q) -------------------------------------------------------------------------------- /qfunc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 8fb90093c5845bb269cfb098c194e04efdee78f32611be813244206d8199602e 8 | 9 | name: qfunc 10 | version: 0.9.1-beta 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/NicklasBoto/funQ#readme 13 | bug-reports: https://github.com/NicklasBoto/funQ/issues 14 | author: Nicklas Botö, 15 | Fabian Forslund, 16 | Matilda Blomqvist, 17 | Beata Burreau, 18 | Marcus Jörgensson, 19 | Joel Rudsberg 20 | maintainer: qfunc@nicbot.xyz 21 | copyright: 2021 Nicklas Botö 22 | license: GPL-3 23 | license-file: LICENSE 24 | build-type: Simple 25 | extra-source-files: 26 | README.md 27 | LICENSE 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/NicklasBoto/funQ 32 | 33 | library 34 | exposed-modules: 35 | AST.AST 36 | FunQ 37 | Interpreter.Interpreter 38 | Interpreter.Run 39 | Lib.Core 40 | Lib.Gates 41 | Lib.Internal.Core 42 | Lib.Internal.Gates 43 | Lib.QM 44 | Parser.Abs 45 | Parser.ErrM 46 | Parser.Lex 47 | Parser.Par 48 | Parser.Print 49 | Parser.Skel 50 | SemanticAnalysis.SemanticAnalysis 51 | Type.TypeChecker 52 | other-modules: 53 | Paths_qfunc 54 | hs-source-dirs: 55 | src 56 | build-depends: 57 | MonadRandom 58 | , array 59 | , base >=4.7 && <5 60 | , bitvec 61 | , containers 62 | , exceptions 63 | , haskeline >=0.8.0.0 64 | , hmatrix 65 | , mtl 66 | , numbers 67 | , parsec 68 | , repline >=0.3.0.0 69 | , turtle 70 | if false 71 | other-modules: 72 | Paths_pkg 73 | default-language: Haskell2010 74 | 75 | executable funq 76 | main-is: Main.hs 77 | other-modules: 78 | Repl 79 | Paths_qfunc 80 | hs-source-dirs: 81 | app 82 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 83 | build-depends: 84 | MonadRandom 85 | , array 86 | , base >=4.7 && <5 87 | , bitvec 88 | , containers 89 | , exceptions 90 | , haskeline >=0.8.0.0 91 | , hmatrix 92 | , mtl 93 | , numbers 94 | , parsec 95 | , qfunc 96 | , repline >=0.3.0.0 97 | , turtle 98 | default-language: Haskell2010 99 | 100 | test-suite qfunc-test 101 | type: exitcode-stdio-1.0 102 | main-is: Spec.hs 103 | other-modules: 104 | GatesTests 105 | InterpreterTests 106 | QStateTests 107 | TestCore 108 | TypeCheckTests 109 | Paths_qfunc 110 | hs-source-dirs: 111 | test 112 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 113 | build-depends: 114 | MonadRandom 115 | , QuickCheck 116 | , array 117 | , base >=4.7 && <5 118 | , bitvec 119 | , containers 120 | , exceptions 121 | , haskeline >=0.8.0.0 122 | , hmatrix 123 | , mtl 124 | , numbers 125 | , parsec 126 | , qfunc 127 | , repline >=0.3.0.0 128 | , turtle 129 | default-language: Haskell2010 130 | -------------------------------------------------------------------------------- /test/GatesTests.hs: -------------------------------------------------------------------------------- 1 | module GatesTests ( 2 | runTests 3 | ) where 4 | 5 | import TestCore 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Monadic as TM 8 | import Numeric.LinearAlgebra as LA 9 | 10 | runTests :: IO Bool 11 | runTests = do 12 | putStrLn "QuickCheck tests unmodified QState sums to 1" 13 | b_sumOne <- quickCheckResult prop_sumOne 14 | 15 | putStrLn "QuickCheck tests sum of QState = 1 after applying gates" 16 | b_sumG <- mapM (quickCheckResult . prop_gate_sum) [hadamard, cnot', pauliX, pauliY, pauliZ, urot 1, phasePi8, identity] 17 | 18 | putStrLn "QuickCheck tests that matrices are unitary" 19 | b_unit <- mapM (quickCheckResult . prop_unitary) [hmat, cmat, phasemat 3, pXmat, pYmat, pZmat, idmat] 20 | 21 | a <- test_rev_gates 22 | putStrLn $ "Tests reversibility of gates on single qubits: " ++ show a 23 | 24 | b <- test_rev_cnot 25 | putStrLn $ "Tests reversibility of cnot with two qubits: " ++ show b 26 | 27 | return $ all isSuccess $ b_sumOne : b_unit ++ b_sumG 28 | 29 | 30 | -- | Checks that the given matrix is unitary 31 | prop_unitary :: Matrix C -> Property 32 | prop_unitary mx = foldl (.&&.) isSquare [ isConjugate, innerHolds mx , normal ] 33 | where isSquare = property $ rows mx == cols mx 34 | isConjugate = property $ (#=) (mx LA.<> conj mx) (ident (rows mx)) 35 | normal = property $ (#=) (conj mx LA.<> mx) (mx LA.<> conj mx) 36 | detIsOne = property $ (~=) (abs (det mx)) 1 37 | 38 | -- | Checks that the inner product holds during matrix transformations 39 | innerHolds :: Matrix C -> Property 40 | innerHolds mx = forAll genNs test 41 | where test bs = (~=) ((#>) mx (randV 0 bs) <.> (#>) mx (randV 1 bs)) (randV 0 bs <.> randV 1 bs) 42 | randV n bs = toColumns (ident (rows mx)) !! (bs !! n) 43 | genNs = vectorOf 2 (choose (0, rows mx - 1)) 44 | 45 | 46 | -- | Checks that the sum of the squared elements in the vector sums to 1 47 | prop_gate_sum :: (QBit -> QM QBit) -> QState -> Property 48 | prop_gate_sum g q = TM.monadicIO $ do 49 | run' $ addState q 50 | (_,size) <- run' getState 51 | qbt <- run' $ getRandQbit size 52 | s <- run' $ applyGate' q g qbt 53 | let su = norm_2 $ state s 54 | TM.assert (su < 1.00001 && su > 0.9999) --due to rounding errors, cannot test == 1 55 | 56 | -- Basic quickCheck test, that unmodified QState sums to 1 57 | prop_sumOne :: QState -> Bool 58 | prop_sumOne (QState v) = norm_2 v == 1 59 | 60 | -- Test reversibility of gates 61 | -- | Given a gate that takes a single qbit, applies it and checks reversibility 62 | test_rev :: (QBit -> QM QBit) -> IO Bool 63 | test_rev g = TestCore.run $ do 64 | qbt <- new 0 65 | (b,a) <- applyTwice qbt g 66 | let bf = map realPart (toList $ state b) 67 | let af = map realPart (toList $ state a) 68 | let cmp = zipWith (\ x y -> abs (x - y)) bf af 69 | return $ all (<0.0000001) cmp -- cannot be checked directly due to rounding errors 70 | 71 | -- All other gates than hadamard could be tested with (state a == state b) 72 | 73 | -- | Applies the reversibility tests to all gates that matches type signature of QBit -> QM QBit. 74 | test_rev_gates :: IO Bool 75 | test_rev_gates = liftM and $ mapM test_rev gates 76 | where gates = [TestCore.phase, hadamard, pauliX, pauliY, pauliZ, phasePi8, identity] 77 | 78 | -- | Test reversibility of cnot 79 | test_rev_cnot :: IO Bool 80 | test_rev_cnot = TestCore.run $ do 81 | q1 <- new 1 82 | q2 <- new 0 83 | b <- get 84 | cnot (q1,q2) >>= cnot 85 | a <- get 86 | return (state a == state b) 87 | -------------------------------------------------------------------------------- /test/TestCore.hs: -------------------------------------------------------------------------------- 1 | module TestCore ( 2 | QState(..), 3 | applyTwice, 4 | run', 5 | addState, 6 | applyGate', 7 | cnot', 8 | getRandQbit, 9 | (~=), 10 | (#=), 11 | genBits, 12 | qrun, 13 | p8mat, 14 | QM, 15 | QM.run, 16 | getState, 17 | QBit, 18 | get, 19 | liftM, 20 | module Lib.Core, 21 | module Lib.Gates, 22 | module Lib.Internal.Gates 23 | ) where 24 | -- TODO: would like TestCore to import everything needed 25 | -- for testing in all other files so just they have to import TestCore 26 | -- and that's it 27 | 28 | import Test.QuickCheck; 29 | import Control.Monad.Random 30 | import FunQ 31 | import Test.QuickCheck.Monadic as TM 32 | import Numeric.LinearAlgebra as LA 33 | import Lib.QM as QM 34 | import Lib.Core 35 | import Lib.Gates 36 | import Lib.Internal.Core 37 | import Lib.Internal.Gates 38 | 39 | -- Arbitrary instance for QState, not very pretty :) 40 | instance Arbitrary QState where 41 | arbitrary = do 42 | b <- elements [0,1] 43 | n <- elements [state $ newVector b, tensorVector (state $ newVector b) (state $ newVector b)] 44 | m <- elements [state $ newVector b, tensorVector (state $ newVector b) (state $ newVector b)] 45 | let s = elements [tensorVector m n] 46 | let t = elements [tensorVector (tensorVector m n) (tensorVector m n)] 47 | e <- frequency [(7,s),(3,t)] 48 | return $ QState e 49 | 50 | 51 | -- | Applies a given gate twice to a given qubit. Returns state before and after the operations 52 | applyTwice :: QBit -> (QBit -> QM QBit) -> QM (QState,QState) 53 | applyTwice qbt g = do 54 | before <- get 55 | once <- applyGate' before g qbt 56 | twice <- applyGate' once g qbt 57 | return (before,twice) 58 | 59 | 60 | -- helper function to run QM computations within the property monad for quickcheck 61 | run' = TM.run . QM.run 62 | 63 | -- | Adds given QState 64 | addState :: QState -> QM QState 65 | addState q = do 66 | put q 67 | get 68 | 69 | -- | Helper function, apply the given gate on a random qubit in state, return the state 70 | applyGate' :: QState -> (QBit -> QM QBit) -> QBit -> QM QState 71 | applyGate' qs g qbt = do 72 | addState qs 73 | g qbt 74 | get 75 | 76 | -- cnot to be used with applyGate for testing purpose 77 | cnot' :: (QBit -> QM QBit) 78 | cnot' q = do 79 | let p = if link q == 0 then Ptr $ link q + 1 else Ptr $ link q - 1 80 | (q',p') <- cnot (q, p) 81 | return p' -- returns pointer to the first qubit only, dummy implementation for matching of types -- trace ("q in cnot': " ++ show q ++ "p in cnot': " ++ show p ++ " p': " ++ show p' ++ " q':" ++ show q') 82 | 83 | -- Returns index between zero and size of QState 84 | --getRandQbit :: Int -> QM QBit 85 | getRandQbit :: Int -> QM QBit 86 | getRandQbit size = do 87 | i <- io $ evalRandIO $ getRandomR (0,size) 88 | return $ Ptr i 89 | 90 | 91 | -- | Compareas two complex numbers for equality to the 6th decimal 92 | (~=) :: C -> C -> Bool 93 | (~=) a b = bm - eqMargin <= am && am <= bm + eqMargin 94 | where am = magnitude a 95 | bm = magnitude b 96 | 97 | -- | The margin allowed for equality checking 98 | eqMargin :: Double 99 | eqMargin = 0.000001 100 | 101 | -- | Compares two complex matrices for equality, using eqAlmost. 102 | (#=) :: Matrix C -> Matrix C -> Bool 103 | (#=) mx nx = all (==True) $ zipWith (~=) list1 list2 104 | where list1 = (concat . toLists) mx 105 | list2 = (concat . toLists) nx 106 | 107 | -- | Generates a bit string of given length 108 | genBits :: Int -> Gen [Bit] 109 | genBits n = vectorOf n (elements [0,1]) 110 | 111 | -- | Runs a QM program in PropertyM 112 | qrun :: QM a -> PropertyM IO a 113 | qrun = TM.run . QM.run 114 | 115 | -- | Test matrices for isUnitary 116 | -- | Hadamard matrix 117 | hmat :: Matrix C 118 | hmat = LA.scale (sqrt 0.5) $ (2 LA.>< 2) 119 | [ 1 , 1 120 | , 1 , -1 ] 121 | 122 | -- | PhasePi8 matrix 123 | p8mat :: Matrix C 124 | p8mat = (2 LA.>< 2) 125 | [ 1 , 0 126 | , 0 , p ] 127 | where p = exp (i * pi / 4) 128 | -------------------------------------------------------------------------------- /src/Parser/Doc.txt: -------------------------------------------------------------------------------- 1 | The Language Parser 2 | BNF Converter 3 | 4 | 5 | %This txt2tags file is machine-generated by the BNF-converter 6 | %Process by txt2tags to generate html or latex 7 | 8 | 9 | 10 | This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). 11 | 12 | ==The lexical structure of Parser== 13 | 14 | ===Literals=== 15 | Integer literals //Integer// are nonempty sequences of digits. 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | FunVar literals are recognized by the regular expression 24 | `````lower (["'_"] | digit | letter)* ' '* ':'````` 25 | 26 | Var literals are recognized by the regular expression 27 | `````lower (["'_"] | digit | letter)*````` 28 | 29 | GateIdent literals are recognized by the regular expression 30 | `````upper (digit | upper)*````` 31 | 32 | Lambda literals are recognized by the regular expression 33 | `````'\'````` 34 | 35 | 36 | ===Reserved words and symbols=== 37 | The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. 38 | 39 | The reserved words used in Parser are the following: 40 | | ``Bit`` | ``CNOT`` | ``FREDKIN`` | ``H`` 41 | | ``I`` | ``QBit`` | ``S`` | ``SWAP`` 42 | | ``T`` | ``TOFFOLI`` | ``X`` | ``Y`` 43 | | ``Z`` | ``else`` | ``if`` | ``in`` 44 | | ``let`` | ``then`` | | 45 | 46 | The symbols used in Parser are the following: 47 | | * | ( | , | ) 48 | | = | . | $ | ! 49 | | >< | -o | | 50 | 51 | ===Comments=== 52 | Single-line comments begin with --.Multiple-line comments are enclosed with {- and -}. 53 | 54 | ==The syntactic structure of Parser== 55 | Non-terminals are enclosed between < and >. 56 | The symbols -> (production), **|** (union) 57 | and **eps** (empty rule) belong to the BNF notation. 58 | All other symbols are terminals. 59 | 60 | | //Program// | -> | //[FunDec]// 61 | | //Term3// | -> | //Var// 62 | | | **|** | //Bit// 63 | | | **|** | //Gate// 64 | | | **|** | //Tup// 65 | | | **|** | ``*`` 66 | | | **|** | ``(`` //Term// ``)`` 67 | | //Term2// | -> | //Term2// //Term3// 68 | | | **|** | //Term3// 69 | | //Term1// | -> | ``if`` //Term// ``then`` //Term// ``else`` //Term// 70 | | | **|** | ``let`` ``(`` //LetVar// ``,`` //[LetVar]// ``)`` ``=`` //Term// ``in`` //Term// 71 | | | **|** | //Lambda// //FunVar// //Type// ``.`` //Term// 72 | | | **|** | //Term2// ``$`` //Term1// 73 | | | **|** | //Term2// 74 | | //Term// | -> | //Term1// 75 | | //LetVar// | -> | //Var// 76 | | //[LetVar]// | -> | //LetVar// 77 | | | **|** | //LetVar// ``,`` //[LetVar]// 78 | | //Tup// | -> | ``(`` //Term// ``,`` //[Term]// ``)`` 79 | | //[Term]// | -> | //Term// 80 | | | **|** | //Term// ``,`` //[Term]// 81 | | //Bit// | -> | //Integer// 82 | | //FunDec// | -> | //FunVar// //Type// //Function// 83 | | //[FunDec]// | -> | **eps** 84 | | | **|** | //FunDec// //[FunDec]// 85 | | //Function// | -> | //Var// //[Arg]// ``=`` //Term// 86 | | //Arg// | -> | //Var// 87 | | //[Arg]// | -> | **eps** 88 | | | **|** | //Arg// //[Arg]// 89 | | //Type2// | -> | ``Bit`` 90 | | | **|** | ``QBit`` 91 | | | **|** | ``T`` 92 | | | **|** | ``!`` //Type2// 93 | | | **|** | ``(`` //Type// ``)`` 94 | | //Type1// | -> | //Type2// ``><`` //Type1// 95 | | | **|** | //Type2// ``-o`` //Type1// 96 | | | **|** | //Type2// 97 | | //Type// | -> | //Type1// 98 | | //Gate// | -> | ``H`` 99 | | | **|** | ``X`` 100 | | | **|** | ``Y`` 101 | | | **|** | ``Z`` 102 | | | **|** | ``I`` 103 | | | **|** | ``S`` 104 | | | **|** | ``T`` 105 | | | **|** | ``CNOT`` 106 | | | **|** | ``TOFFOLI`` 107 | | | **|** | ``SWAP`` 108 | | | **|** | ``FREDKIN`` 109 | | | **|** | //GateIdent// 110 | 111 | 112 | -------------------------------------------------------------------------------- /src/Parser/Doc.txt.bak: -------------------------------------------------------------------------------- 1 | The Language Parser 2 | BNF Converter 3 | 4 | 5 | %This txt2tags file is machine-generated by the BNF-converter 6 | %Process by txt2tags to generate html or latex 7 | 8 | 9 | 10 | This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). 11 | 12 | ==The lexical structure of Parser== 13 | 14 | ===Literals=== 15 | Integer literals //Integer// are nonempty sequences of digits. 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | FunVar literals are recognized by the regular expression 24 | `````lower (["'_"] | digit | letter)* ' '* ':'````` 25 | 26 | Var literals are recognized by the regular expression 27 | `````lower (["'_"] | digit | letter)*````` 28 | 29 | GateIdent literals are recognized by the regular expression 30 | `````upper (digit | upper)*````` 31 | 32 | Lambda literals are recognized by the regular expression 33 | `````'\'````` 34 | 35 | 36 | ===Reserved words and symbols=== 37 | The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. 38 | 39 | The reserved words used in Parser are the following: 40 | | ``Bit`` | ``CNOT`` | ``FREDKIN`` | ``H`` 41 | | ``I`` | ``QBit`` | ``S`` | ``SWAP`` 42 | | ``T`` | ``TOFFOLI`` | ``X`` | ``Y`` 43 | | ``Z`` | ``else`` | ``if`` | ``in`` 44 | | ``let`` | ``then`` | | 45 | 46 | The symbols used in Parser are the following: 47 | | * | $ | ( | , 48 | | ) | = | . | ! 49 | | >< | -o | | 50 | 51 | ===Comments=== 52 | Single-line comments begin with --.Multiple-line comments are enclosed with {- and -}. 53 | 54 | ==The syntactic structure of Parser== 55 | Non-terminals are enclosed between < and >. 56 | The symbols -> (production), **|** (union) 57 | and **eps** (empty rule) belong to the BNF notation. 58 | All other symbols are terminals. 59 | 60 | | //Program// | -> | //[FunDec]// 61 | | //Term4// | -> | //Var// 62 | | | **|** | //Bit// 63 | | | **|** | //Gate// 64 | | | **|** | //Tup// 65 | | | **|** | ``*`` 66 | | | **|** | ``(`` //Term// ``)`` 67 | | //Term3// | -> | //Term3// ``$`` //Term4// 68 | | | **|** | //Term4// 69 | | //Term2// | -> | //Term2// //Term3// 70 | | | **|** | //Term3// 71 | | //Term1// | -> | ``if`` //Term// ``then`` //Term// ``else`` //Term// 72 | | | **|** | ``let`` ``(`` //LetVar// ``,`` //[LetVar]// ``)`` ``=`` //Term// ``in`` //Term// 73 | | | **|** | //Lambda// //FunVar// //Type// ``.`` //Term// 74 | | | **|** | //Term2// 75 | | //Term// | -> | //Term1// 76 | | //LetVar// | -> | //Var// 77 | | //[LetVar]// | -> | //LetVar// 78 | | | **|** | //LetVar// ``,`` //[LetVar]// 79 | | //Tup// | -> | ``(`` //Term// ``,`` //[Term]// ``)`` 80 | | //[Term]// | -> | //Term// 81 | | | **|** | //Term// ``,`` //[Term]// 82 | | //Bit// | -> | //Integer// 83 | | //FunDec// | -> | //FunVar// //Type// //Function// 84 | | //[FunDec]// | -> | **eps** 85 | | | **|** | //FunDec// //[FunDec]// 86 | | //Function// | -> | //Var// //[Arg]// ``=`` //Term// 87 | | //Arg// | -> | //Var// 88 | | //[Arg]// | -> | **eps** 89 | | | **|** | //Arg// //[Arg]// 90 | | //Type2// | -> | ``Bit`` 91 | | | **|** | ``QBit`` 92 | | | **|** | ``T`` 93 | | | **|** | ``!`` //Type2// 94 | | | **|** | ``(`` //Type// ``)`` 95 | | //Type1// | -> | //Type2// ``><`` //Type1// 96 | | | **|** | //Type2// ``-o`` //Type1// 97 | | | **|** | //Type2// 98 | | //Type// | -> | //Type1// 99 | | //Gate// | -> | ``H`` 100 | | | **|** | ``X`` 101 | | | **|** | ``Y`` 102 | | | **|** | ``Z`` 103 | | | **|** | ``I`` 104 | | | **|** | ``S`` 105 | | | **|** | ``T`` 106 | | | **|** | ``CNOT`` 107 | | | **|** | ``TOFFOLI`` 108 | | | **|** | ``SWAP`` 109 | | | **|** | ``FREDKIN`` 110 | | | **|** | //GateIdent// 111 | 112 | 113 | -------------------------------------------------------------------------------- /src/Lib/Internal/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | {-| 4 | Module : Internal.Core 5 | Description : Core language internals 6 | Stability : experimental 7 | 8 | Internal matrix and measurment operations 9 | -} 10 | module Lib.Internal.Core where 11 | 12 | import Data.Bit ( Bit ) 13 | import Lib.QM ( QState(QState), Ix, QBit (Ptr), stateSize ) 14 | import Data.Bits ( Bits((.&.)) ) 15 | import Numeric.LinearAlgebra 16 | ( Complex, 17 | magnitude, 18 | flatten, 19 | outer, 20 | normalize, 21 | size, 22 | toList, 23 | fromList, 24 | C, 25 | Vector ) 26 | import qualified Control.Monad.Random as Rand ( fromList, evalRandIO ) 27 | 28 | -- | Appends state with tensor 29 | appendState :: QState -> QState -> QState 30 | appendState (QState new) (QState []) = QState new 31 | appendState (QState new) (QState state) = QState $ tensorVector new state 32 | 33 | 34 | -- | Tensor product between two vectors 35 | tensorVector :: Vector C -> Vector C -> Vector C 36 | tensorVector newVector oldVector = flatten $ outer oldVector newVector 37 | 38 | -- | Vector state representations of qubits with 100% probaility 39 | -- to collapse to their bit counterparts 40 | newVector :: Bit -> QState 41 | newVector 0 = QState [1, 0] 42 | newVector 1 = QState [0, 1] 43 | 44 | 45 | -- Model probability as a rational number. 46 | type Prob = Rational 47 | 48 | -- | Finds the probability of the qubit measing to a 1. 49 | -- Find all the amplitudes where that qubit is one and converts it to probabilities. 50 | findQbitProb1 :: QBit -> QState -> Prob 51 | findQbitProb1 qbit qstate = sum $ map ampToProb (findMarginAmps1 qbit qstate) 52 | 53 | type Amplitude = Complex Double 54 | 55 | -- | Finds the amplitudes from all the positions where that qubit is one. 56 | findMarginAmps1 :: QBit -> QState -> [Amplitude] 57 | findMarginAmps1 qbit qstate = map snd $ filter isMargin allAmps 58 | where 59 | allAmps :: [(Ix, Amplitude)] 60 | allAmps = qstateAmps qstate 61 | 62 | isMargin :: (Ix, Amplitude) -> Bool 63 | isMargin (ix, _) = maskMatch ix ixMask -- This implies that the amplitude deals with a case where the given qbit measures to a 1 64 | ixMask = qbitMask qbit qstate 65 | 66 | -- | If all the bits in b are in a it is a match. 67 | maskMatch :: Int -> Int -> Bool 68 | maskMatch a b = a .&. b == b 69 | 70 | -- | Given a qbit, finds its mask in the qstate. 71 | -- E.g. an amplitude in a 3 qbits state could be |100>. 72 | -- A mask of 100=8 is wanted if the zero'th qbit is in interest, same mask would work for |101>. 73 | -- If qbit is 1 we want it to be 010=4... 74 | qbitMask :: QBit -> QState -> Int 75 | qbitMask (Ptr qbitIx) qstate = 2^(numQbits - 1 - qbitIx) 76 | where 77 | numQbits = stateSize qstate 78 | 79 | -- | Given a complex amplitude, will return its probability. 80 | ampToProb :: Amplitude -> Prob 81 | ampToProb = toRational . (^2) . magnitude 82 | 83 | -- | Removes the states that contradict the measurment from the qbit to bit, also normalizes the state to a length of one. 84 | remImpossibleStates :: QState -> QBit -> Bit -> QState 85 | remImpossibleStates qstate qbit bit = (QState . normalize . fromList . map transformAmp) amps 86 | where 87 | amps = qstateAmps qstate 88 | ixMask = qbitMask qbit qstate 89 | 90 | -- If the index is at a impossible state, then amplitude is set to 0, else it is kept. 91 | transformAmp :: (Ix, Amplitude) -> Amplitude 92 | transformAmp (ix, amp) | impossibleState ix = 0 93 | | otherwise = amp 94 | 95 | -- If the mask is a match we are at a position where that qubit is a 1, if the bit is measured 96 | -- as a 0 we are at impossible state. Or the opposite, if the position is where qbit is 0 97 | -- we are impossible if we measured a one. 98 | impossibleState :: Ix -> Bool 99 | impossibleState ix | maskMatch ix ixMask = bit == 0 100 | | otherwise = bit == 1 101 | 102 | 103 | -- | From a qstate, returns the amplitudes with its indexes. 104 | qstateAmps :: QState -> [(Ix, Amplitude)] 105 | qstateAmps (QState stateVector) = zip [0..] (toList stateVector) 106 | 107 | -- Uses random number generator to return a bit according to the probabilites given. 108 | rngQbit :: Prob -> IO Bit 109 | rngQbit p1 = Rand.evalRandIO $ Rand.fromList [(0, 1-p1), (1, p1)] 110 | -------------------------------------------------------------------------------- /src/Lib/QM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | {-| 6 | Module : QM 7 | Description : The Quantum Monad 8 | Stability : experimental 9 | 10 | Definition of the quantum monad (`QM`) and helper functions 11 | -} 12 | module Lib.QM ( 13 | -- * The Quantum Monad 14 | QM 15 | , run 16 | , runDebug 17 | , eval 18 | , put 19 | , get 20 | , modify 21 | , io 22 | 23 | -- * Quantum State representation 24 | , QState(..) 25 | 26 | -- * QBit 27 | , Ix 28 | , QBit(..) 29 | 30 | -- * Helpers 31 | , checkState 32 | , getState 33 | , stateSize 34 | ) where 35 | 36 | import Numeric.LinearAlgebra 37 | ( size, toList, C, Vector, magnitude ) 38 | import Data.List ( intercalate ) 39 | import qualified Control.Monad.Random as Rand ( fromList, evalRandIO ) 40 | 41 | -- | Internal index type, to indicate it is a qubit index. 42 | type Ix = Int 43 | 44 | -- | Pointer to a qubit in QState. 45 | -- Represents the linking function in QLambda 46 | newtype QBit = Ptr { link :: Ix } 47 | deriving (Show, Read) 48 | 49 | -- | The program state, a complex vector representation of 50 | -- the qubits in the system 51 | newtype QState = QState { state :: Vector C } 52 | 53 | instance Show QState where 54 | show (QState q) = "== QState: " ++ s ++ " ==\n" 55 | ++ intercalate "\n" (map show $ toList q) ++ "\n" 56 | where s = show $ size q 57 | 58 | instance Eq QState where 59 | (==) (QState q1) (QState q2) = and $ zipWith (~=) (toList q1) (toList q2) 60 | 61 | -- | Compareas two complex numbers for equality to the 6th decimal 62 | (~=) :: C -> C -> Bool 63 | (~=) a b = bm - eqMargin <= am && am <= bm + eqMargin 64 | where am = magnitude a 65 | bm = magnitude b 66 | eqMargin = 0.000001 67 | 68 | -- | The Quantum Monad 69 | -- Keeps a state of the complex vector representation while allowing 70 | -- pseudo-random number generation 71 | newtype QM a = QM { runQM :: QState -> IO (a, QState) } 72 | 73 | instance Show (QM a) where 74 | show _q = "Please use the function 'run' to perform the simulation" 75 | 76 | instance Functor QM where 77 | fmap f m = m >>= return . f 78 | 79 | instance Applicative QM where 80 | pure a = QM \s -> return (a,s) 81 | {-# INLINE pure #-} 82 | QM af <*> QM ax = QM \s -> do 83 | (f, s') <- af s 84 | (x, s'') <- ax s' 85 | return (f x, s'') 86 | 87 | instance Monad QM where 88 | return = pure 89 | m >>= k = QM \s -> do 90 | (a, s') <- runQM m s 91 | runQM (k a) s' 92 | 93 | instance MonadFail QM where 94 | fail s = error $ "Panic behavior!" ++ " " ++ s 95 | 96 | -- | Perform IO action inside the quantum monad 97 | io :: IO a -> QM a 98 | io m = QM \s -> do 99 | a <- m 100 | return (a,s) 101 | {-# INLINE io #-} 102 | 103 | -- | Replace the quantum state 104 | put :: QState -> QM () 105 | put s = QM \_ -> return ((), s) 106 | {-# INLINE put #-} 107 | 108 | -- | Fetch the quantum state 109 | get :: QM QState 110 | get = QM \s -> return (s,s) 111 | {-# INLINE get #-} 112 | 113 | -- | Apply a function to the quantum state 114 | modify :: (QState -> QState) -> QM () 115 | modify f = QM \s -> return ((), f s) 116 | {-# INLINE modify #-} 117 | 118 | -- | Run quantum program 119 | eval :: QM a -> IO (a, QState) 120 | eval qm = runQM qm (QState []) 121 | {-# INLINE eval #-} 122 | 123 | -- | Run quantum program, discarding it's final state 124 | run :: QM a -> IO a 125 | run qm = fst <$> eval qm 126 | {-# INLINE run #-} 127 | 128 | -- | Run quantum program, prints the final quantum state and returns the result 129 | runDebug :: QM a -> IO a 130 | runDebug qm = do 131 | (a, s) <- eval qm 132 | print s 133 | return a 134 | 135 | -- | Given a QState, returns how many qbits it consists of. 136 | stateSize :: QState -> Ix 137 | stateSize q = case size (state q) of 138 | 0 -> 0 139 | x -> log2 x 140 | 141 | -- | Normal integer log with base 2. 142 | log2 :: Integral a => a -> Ix 143 | log2 = floor . logBase 2 . fromIntegral 144 | 145 | -- | Returns the quantum state together with it's size 146 | getState :: QM (QState, Int) 147 | getState = do 148 | s <- get 149 | let size = stateSize s 150 | return (s, size) 151 | 152 | -- | Print the quantum state during operation 153 | checkState :: QM () 154 | checkState = do 155 | state <- get 156 | io $ print state 157 | -------------------------------------------------------------------------------- /src/Lib/Internal/Gates.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | 4 | {-| 5 | Module : Internal.Gates 6 | Description : Gate library internals 7 | Stability : experimental 8 | 9 | Internal matrix operations 10 | -} 11 | module Lib.Internal.Gates where 12 | 13 | import Lib.QM ( getState, get, put, QM, QState(QState), QBit(..), Ix) 14 | import Numeric.LinearAlgebra 15 | ( Complex(..), 16 | C, 17 | (#>), 18 | (><), 19 | dispcf, 20 | ident, 21 | kronecker, 22 | Matrix, 23 | Linear(scale), Convert (toComplex), mkPolar ) 24 | 25 | instance {-# OVERLAPS#-} Show (Matrix C) where 26 | show mx = dispcf 3 mx 27 | 28 | -- | The imaginary unit 29 | i :: Complex Double 30 | i = 0 :+ 1 31 | 32 | applyParallel :: Matrix C -> Matrix C -> Matrix C 33 | applyParallel = kronecker 34 | 35 | -- | Apply gate to the current quantum state 36 | applyGate :: Matrix C -> QM () 37 | applyGate g = do 38 | (QState v) <- get 39 | put $ QState $ g #> v 40 | 41 | -- | Changes an element at an index in a list. 42 | -- index 0 will change the first element. 43 | changeAt :: a -> Int -> [a] -> [a] 44 | changeAt x index [] = error "changeAt: Can't change an element in an empty list" 45 | changeAt x 0 (_:ys) = x:ys 46 | changeAt x index (y:ys) = y : changeAt x (index - 1) ys 47 | 48 | -- | Apply a 2x2 gate, to a specific qubit. 49 | -- 50 | -- It will update the qstate. 51 | runGate :: Matrix C -> (QBit -> QM QBit) 52 | runGate g x = do 53 | (state, size) <- getState 54 | let ids = replicate size (ident 2) 55 | let list = changeAt g (link x) ids 56 | let m = foldr1 applyParallel list 57 | applyGate m 58 | return x 59 | 60 | -- run specified gates in parallel 61 | -- TODO: should work, but not fully tested. does NOT work with controlled gates 62 | parallel :: Int -> [(Matrix C, QBit)] -> Matrix C 63 | parallel size as = foldr1 applyParallel list 64 | where list = foldr apply (replicate size $ ident 2) as 65 | apply :: (Matrix C, QBit) -> [Matrix C] -> [Matrix C] 66 | apply (mx, Ptr q) nx = changeAt mx q nx 67 | 68 | -- | Produce matrix running a gate controlled by another bit 69 | controlMatrix :: Int -> QBit -> QBit -> Matrix C -> Matrix C 70 | controlMatrix size (Ptr c) (Ptr t) g = fl + fr 71 | where idsl = replicate size (ident 2) 72 | idsr = replicate size (ident 2) 73 | l = changeAt proj0 c idsl 74 | rc = changeAt proj1 c idsr 75 | r = changeAt g t rc 76 | fl = foldr1 applyParallel l 77 | fr = foldr1 applyParallel r 78 | -- | Produce a matrix running a gate controlled by two other bits 79 | ccontrolMatrix :: Int -> QBit -> QBit -> QBit -> Matrix C -> Matrix C 80 | ccontrolMatrix size (Ptr c1) (Ptr c2) (Ptr t) g = f00 + f01 + f10 + f11 81 | where ids = replicate size (ident 2) 82 | m00c = changeAt proj0 c2 $ changeAt proj0 c1 ids 83 | m01c = changeAt proj1 c2 $ changeAt proj0 c1 ids 84 | m10c = changeAt proj0 c2 $ changeAt proj1 c1 ids 85 | m11c = changeAt proj1 c2 $ changeAt proj1 c1 $ changeAt g t ids 86 | f00 = foldr1 applyParallel m00c 87 | f01 = foldr1 applyParallel m01c 88 | f10 = foldr1 applyParallel m10c 89 | f11 = foldr1 applyParallel m11c 90 | 91 | -- | Quantum fourier transform matrix 92 | qftMatrix :: Int -> Matrix C 93 | qftMatrix n = (1 / sqrt (fromIntegral n)) * (n >< n) 94 | [ ω^(j*k) | j <- [0..n-1], k <- [0..n-1] ] 95 | where ω = exp ((2*pi*i) / fromIntegral n) 96 | 97 | notAdjacent :: [Ix] -> Bool 98 | notAdjacent [a] = False 99 | notAdjacent [a, b] = b-a /= 1 100 | notAdjacent (a:b:as) = b-a /= 1 || notAdjacent (b:as) 101 | 102 | -- | Projection of the zero basis vector 103 | proj0 :: Matrix C 104 | proj0 = (2 >< 2) 105 | [ 1 , 0 106 | , 0 , 0 ] 107 | 108 | -- | Projection of the one basis vector 109 | proj1 :: Matrix C 110 | proj1 = (2 >< 2) 111 | [ 0 , 0 112 | , 0 , 1 ] 113 | 114 | -- | Hadamard matrix 115 | hmat :: Matrix C 116 | hmat = scale (sqrt 0.5) $ (2 >< 2) 117 | [ 1 , 1 118 | , 1 , -1 ] 119 | 120 | -- | CNOT matrix 121 | cmat :: Matrix C 122 | cmat = (4 >< 4) 123 | [ 1, 0, 0, 0 124 | , 0, 1, 0, 0 125 | , 0, 0, 0, 1 126 | , 0, 0, 1, 0 ] 127 | 128 | -- | Generic phase matrix, takes in phase change as radians 129 | phasemat :: Double -> Matrix C 130 | phasemat r = (2 >< 2) 131 | [ 1, 0 132 | , 0, p ] 133 | where p = exp (0 :+ 2*pi*r)--(i*(r :+ 0)) 134 | 135 | -- | PauliX matrix 136 | pXmat :: Matrix C 137 | pXmat = (2 >< 2) 138 | [ 0, 1 139 | , 1, 0 ] 140 | 141 | -- | PauliY matrix 142 | pYmat :: Matrix C 143 | pYmat = (2 >< 2) 144 | [ 0, -i 145 | , i, 0 ] 146 | 147 | -- | PauliZ matrix 148 | pZmat :: Matrix C 149 | pZmat = (2 >< 2) 150 | [ 1 , 0 151 | , 0 , -1 ] 152 | 153 | -- | Identity matrix 154 | idmat :: Matrix C 155 | idmat = (2 >< 2) 156 | [ 1 , 0 157 | , 0 , 1 ] 158 | -------------------------------------------------------------------------------- /legacy/Gates.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE BlockArguments #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 9 | {-# OPTIONS_HADDOCK not-home #-} 10 | 11 | {-| 12 | Module : Gates 13 | Description : Gate library 14 | Stability : experimental 15 | 16 | Module containing unitary gates and their matrix representations. 17 | -} 18 | module Gates where 19 | 20 | import QData 21 | import Numeric.LinearAlgebra.Static as V hiding ( outer ) 22 | import Numeric.LinearAlgebra ( flatten, outer, kronecker, ident, toList ) 23 | import qualified Numeric.LinearAlgebra as LA ( (><) ) 24 | import GHC.TypeLits ( Nat, type (+), type (^), KnownNat, natVal ) 25 | import Data.Proxy ( Proxy(..) ) 26 | import Prelude hiding ( id ) 27 | 28 | -- | Pauli-X gate 29 | -- 30 | -- \[ \text{X} = \begin{bmatrix} 31 | -- 0 & 1 \\ 32 | -- 1 & 0 33 | -- \end{bmatrix} \] 34 | -- 35 | -- ![pauliX](images/x.PNG) 36 | pauliX :: Gate 1 37 | pauliX = fromMatrix $ fromList 38 | [ 0 , 1 39 | , 1 , 0 ] 40 | 41 | -- | Pauli-Y gate 42 | -- 43 | -- \[ \text{Y} = \begin{bmatrix} 44 | -- 0 & -i \\ 45 | -- i & 0 46 | -- \end{bmatrix} \] 47 | -- 48 | -- ![pauliY](images/y.PNG) 49 | pauliY :: Gate 1 50 | pauliY = fromMatrix $ fromList 51 | [ 0 , -i 52 | , i , 0 ] 53 | 54 | -- | Pauli-Z gate 55 | -- 56 | -- \[ \text{Z} = \begin{bmatrix} 57 | -- 1 & 0 \\ 58 | -- 0 & -1 59 | -- \end{bmatrix} \] 60 | -- 61 | -- ![pauliZ](images/z.PNG) 62 | pauliZ :: Gate 1 63 | pauliZ = fromMatrix $ fromList 64 | [ 1 , 0 65 | , 0 , -1 ] 66 | 67 | -- | Hadamard gate 68 | -- 69 | -- \[ \text{X} = \frac1{\sqrt2} \begin{bmatrix} 70 | -- 0 & 1 \\ 71 | -- 1 & 0 72 | -- \end{bmatrix} \] 73 | -- 74 | -- ![hadamard](images/h.PNG) 75 | 76 | hadamard :: Gate 1 77 | hadamard = fromMatrix $ sqrt 0.5 * fromList 78 | [ 1 , 1 79 | , 1 , -1 ] 80 | 81 | 82 | -- | Phase gate 83 | -- 84 | -- \[ \text{S} = \begin{bmatrix} 85 | -- 1 & 0 \\ 86 | -- 0 & i 87 | -- \end{bmatrix} \] 88 | -- 89 | -- ![phase](images/s.PNG) 90 | phase :: Gate 1 91 | phase = fromMatrix $ fromList 92 | [ 1 , 0 93 | , 0 , i ] 94 | 95 | -- | Pi/8 gate (T gate) 96 | -- 97 | -- \[ \text{T} = \begin{bmatrix} 98 | -- 1 & 0 \\ 99 | -- 0 & e^{i\pi/4} 100 | -- \end{bmatrix} \] 101 | -- 102 | -- ![pi8](images/t.PNG) 103 | phasePi8 :: Gate 1 104 | phasePi8 = fromMatrix $ fromList 105 | [ 1 , 0 106 | , 0 , p ] 107 | where p = exp (i * pi / 8) 108 | 109 | 110 | -- | CNOT gate 111 | -- 112 | -- \[ \text{CNOT} = \begin{bmatrix} 113 | -- 1 & 0 & 0 & 0 \\ 114 | -- 0 & 1 & 0 & 0 \\ 115 | -- 0 & 0 & 0 & 1 \\ 116 | -- 0 & 0 & 1 & 0 117 | -- \end{bmatrix} 118 | -- \] 119 | -- 120 | -- ![cnot](images/cnot.PNG) 121 | cnot :: Gate 2 122 | cnot = fromMatrix $ fromList 123 | [ 1, 0, 0, 0 124 | , 0, 1, 0, 0 125 | , 0, 0, 0, 1 126 | , 0, 0, 1, 0 ] 127 | 128 | -- | SWAP gate 129 | -- 130 | -- \[ \text{SWAP} = \begin{bmatrix} 131 | -- 1 & 0 & 0 & 0 \\ 132 | -- 0 & 0 & 1 & 0 \\ 133 | -- 0 & 1 & 0 & 0 \\ 134 | -- 0 & 0 & 0 & 1 135 | -- \end{bmatrix} 136 | -- \] 137 | -- 138 | -- ![swap](images/swap.PNG) 139 | swap :: Gate 2 140 | swap = fromMatrix $ fromList 141 | [ 1, 0, 0, 0 142 | , 0, 0, 1, 0 143 | , 0, 1, 0, 0 144 | , 0, 0, 0, 1 ] 145 | 146 | -- | Toffoli gate 147 | -- 148 | -- \[ \begin{bmatrix} 149 | -- 1 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ 150 | -- 0 & 1 & 0 & 0 & 0 & 0 & 0 & 0 \\ 151 | -- 0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 \\ 152 | -- 0 & 0 & 0 & 1 & 0 & 0 & 0 & 0 \\ 153 | -- 0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 \\ 154 | -- 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 \\ 155 | -- 0 & 0 & 0 & 0 & 0 & 0 & 0 & 1 \\ 156 | -- 0 & 0 & 0 & 0 & 0 & 0 & 1 & 0 157 | -- \end{bmatrix} \] 158 | -- 159 | -- ![toffoli](images/toffoli.PNG) 160 | toffoli :: Gate 3 161 | toffoli = fromMatrix $ fromList 162 | [ 1, 0, 0, 0, 0, 0, 0, 0 163 | , 0, 1, 0, 0, 0, 0, 0, 0 164 | , 0, 0, 1, 0, 0, 0, 0, 0 165 | , 0, 0, 0, 1, 0, 0, 0, 0 166 | , 0, 0, 0, 0, 1, 0, 0, 0 167 | , 0, 0, 0, 0, 0, 1, 0, 0 168 | , 0, 0, 0, 0, 0, 0, 0, 1 169 | , 0, 0, 0, 0, 0, 0, 1, 0 ] 170 | 171 | -- | The identity gate 172 | identity :: forall (n :: Nat) . KnownNat n => Gate n 173 | identity = fromMatrix let dim = natVal (Proxy :: Proxy n) 174 | in case create $ ident $ fromInteger $ 2^dim of 175 | Just i -> i 176 | Nothing -> errorWithoutStackTrace 177 | "Could not deduce matrix dimensions" 178 | 179 | -- | Control a gate with a classical bit 180 | controlbit :: KnownNat n => Gate n -> Bit 1 -> Gate n 181 | controlbit g 1 = g 182 | controlbit g 0 = identity 183 | 184 | beamsplitter :: Gate 1 185 | beamsplitter = fromMatrix $ sqrt 0.5 * fromList 186 | [ 1 , i 187 | , i , 1 ] -------------------------------------------------------------------------------- /src/Parser/Par.y: -------------------------------------------------------------------------------- 1 | -- This Happy file was machine-generated by the BNF converter 2 | { 3 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} 4 | module Parser.Par 5 | ( happyError 6 | , myLexer 7 | , pProgram 8 | , pTerm3 9 | , pTerm2 10 | , pTerm1 11 | , pTerm 12 | , pLetVar 13 | , pListLetVar 14 | , pTup 15 | , pListTerm 16 | , pBit 17 | , pFunDec 18 | , pListFunDec 19 | , pFunction 20 | , pArg 21 | , pListArg 22 | , pType2 23 | , pType1 24 | , pType 25 | , pGate 26 | ) where 27 | import qualified Parser.Abs 28 | import Parser.Lex 29 | } 30 | 31 | %name pProgram Program 32 | %name pTerm3 Term3 33 | %name pTerm2 Term2 34 | %name pTerm1 Term1 35 | %name pTerm Term 36 | %name pLetVar LetVar 37 | %name pListLetVar ListLetVar 38 | %name pTup Tup 39 | %name pListTerm ListTerm 40 | %name pBit Bit 41 | %name pFunDec FunDec 42 | %name pListFunDec ListFunDec 43 | %name pFunction Function 44 | %name pArg Arg 45 | %name pListArg ListArg 46 | %name pType2 Type2 47 | %name pType1 Type1 48 | %name pType Type 49 | %name pGate Gate 50 | -- no lexer declaration 51 | %monad { Either String } { (>>=) } { return } 52 | %tokentype {Token} 53 | %token 54 | '!' { PT _ (TS _ 1) } 55 | '$' { PT _ (TS _ 2) } 56 | '(' { PT _ (TS _ 3) } 57 | ')' { PT _ (TS _ 4) } 58 | '*' { PT _ (TS _ 5) } 59 | ',' { PT _ (TS _ 6) } 60 | '-o' { PT _ (TS _ 7) } 61 | '.' { PT _ (TS _ 8) } 62 | '=' { PT _ (TS _ 9) } 63 | '><' { PT _ (TS _ 10) } 64 | 'Bit' { PT _ (TS _ 11) } 65 | 'CNOT' { PT _ (TS _ 12) } 66 | 'FREDKIN' { PT _ (TS _ 13) } 67 | 'H' { PT _ (TS _ 14) } 68 | 'I' { PT _ (TS _ 15) } 69 | 'QBit' { PT _ (TS _ 16) } 70 | 'S' { PT _ (TS _ 17) } 71 | 'SWAP' { PT _ (TS _ 18) } 72 | 'T' { PT _ (TS _ 19) } 73 | 'TOFFOLI' { PT _ (TS _ 20) } 74 | 'X' { PT _ (TS _ 21) } 75 | 'Y' { PT _ (TS _ 22) } 76 | 'Z' { PT _ (TS _ 23) } 77 | 'else' { PT _ (TS _ 24) } 78 | 'if' { PT _ (TS _ 25) } 79 | 'in' { PT _ (TS _ 26) } 80 | 'let' { PT _ (TS _ 27) } 81 | 'then' { PT _ (TS _ 28) } 82 | L_integ { PT _ (TI $$) } 83 | L_FunVar { PT _ (T_FunVar $$) } 84 | L_Var { PT _ (T_Var $$) } 85 | L_GateIdent { PT _ (T_GateIdent $$) } 86 | L_Lambda { PT _ (T_Lambda $$) } 87 | 88 | %% 89 | 90 | Integer :: { Integer } 91 | Integer : L_integ { (read ($1)) :: Integer } 92 | 93 | FunVar :: { Parser.Abs.FunVar} 94 | FunVar : L_FunVar { Parser.Abs.FunVar $1 } 95 | 96 | Var :: { Parser.Abs.Var} 97 | Var : L_Var { Parser.Abs.Var $1 } 98 | 99 | GateIdent :: { Parser.Abs.GateIdent} 100 | GateIdent : L_GateIdent { Parser.Abs.GateIdent $1 } 101 | 102 | Lambda :: { Parser.Abs.Lambda} 103 | Lambda : L_Lambda { Parser.Abs.Lambda $1 } 104 | 105 | Program :: { Parser.Abs.Program } 106 | Program : ListFunDec { Parser.Abs.PDef $1 } 107 | 108 | Term3 :: { Parser.Abs.Term } 109 | Term3 : Var { Parser.Abs.TVar $1 } 110 | | Bit { Parser.Abs.TBit $1 } 111 | | Gate { Parser.Abs.TGate $1 } 112 | | Tup { Parser.Abs.TTup $1 } 113 | | '*' { Parser.Abs.TStar } 114 | | '(' Term ')' { $2 } 115 | 116 | Term2 :: { Parser.Abs.Term } 117 | Term2 : Term2 Term3 { Parser.Abs.TApp $1 $2 } | Term3 { $1 } 118 | 119 | Term1 :: { Parser.Abs.Term } 120 | Term1 : 'if' Term 'then' Term 'else' Term { Parser.Abs.TIfEl $2 $4 $6 } 121 | | 'let' '(' LetVar ',' ListLetVar ')' '=' Term 'in' Term { Parser.Abs.TLet $3 $5 $8 $10 } 122 | | Lambda FunVar Type '.' Term { Parser.Abs.TLamb $1 $2 $3 $5 } 123 | | Term2 '$' Term1 { Parser.Abs.TDolr $1 $3 } 124 | | Term2 { $1 } 125 | 126 | Term :: { Parser.Abs.Term } 127 | Term : Term1 { $1 } 128 | 129 | LetVar :: { Parser.Abs.LetVar } 130 | LetVar : Var { Parser.Abs.LVar $1 } 131 | 132 | ListLetVar :: { [Parser.Abs.LetVar] } 133 | ListLetVar : LetVar { (:[]) $1 } 134 | | LetVar ',' ListLetVar { (:) $1 $3 } 135 | 136 | Tup :: { Parser.Abs.Tup } 137 | Tup : '(' Term ',' ListTerm ')' { Parser.Abs.Tuple $2 $4 } 138 | 139 | ListTerm :: { [Parser.Abs.Term] } 140 | ListTerm : Term { (:[]) $1 } | Term ',' ListTerm { (:) $1 $3 } 141 | 142 | Bit :: { Parser.Abs.Bit } 143 | Bit : Integer { Parser.Abs.BBit $1 } 144 | 145 | FunDec :: { Parser.Abs.FunDec } 146 | FunDec : FunVar Type Function { Parser.Abs.FDecl $1 $2 $3 } 147 | 148 | ListFunDec :: { [Parser.Abs.FunDec] } 149 | ListFunDec : {- empty -} { [] } | FunDec ListFunDec { (:) $1 $2 } 150 | 151 | Function :: { Parser.Abs.Function } 152 | Function : Var ListArg '=' Term { Parser.Abs.FDef $1 $2 $4 } 153 | 154 | Arg :: { Parser.Abs.Arg } 155 | Arg : Var { Parser.Abs.FArg $1 } 156 | 157 | ListArg :: { [Parser.Abs.Arg] } 158 | ListArg : {- empty -} { [] } | Arg ListArg { (:) $1 $2 } 159 | 160 | Type2 :: { Parser.Abs.Type } 161 | Type2 : 'Bit' { Parser.Abs.TypeBit } 162 | | 'QBit' { Parser.Abs.TypeQbit } 163 | | 'T' { Parser.Abs.TypeUnit } 164 | | '!' Type2 { Parser.Abs.TypeDup $2 } 165 | | '(' Type ')' { $2 } 166 | 167 | Type1 :: { Parser.Abs.Type } 168 | Type1 : Type2 '><' Type1 { Parser.Abs.TypeTens $1 $3 } 169 | | Type2 '-o' Type1 { Parser.Abs.TypeFunc $1 $3 } 170 | | Type2 { $1 } 171 | 172 | Type :: { Parser.Abs.Type } 173 | Type : Type1 { $1 } 174 | 175 | Gate :: { Parser.Abs.Gate } 176 | Gate : 'H' { Parser.Abs.GH } 177 | | 'X' { Parser.Abs.GX } 178 | | 'Y' { Parser.Abs.GY } 179 | | 'Z' { Parser.Abs.GZ } 180 | | 'I' { Parser.Abs.GI } 181 | | 'S' { Parser.Abs.GS } 182 | | 'T' { Parser.Abs.GT } 183 | | 'CNOT' { Parser.Abs.GCNOT } 184 | | 'TOFFOLI' { Parser.Abs.GTOF } 185 | | 'SWAP' { Parser.Abs.GSWP } 186 | | 'FREDKIN' { Parser.Abs.GFRDK } 187 | | GateIdent { Parser.Abs.GIdent $1 } 188 | { 189 | 190 | happyError :: [Token] -> Either String a 191 | happyError ts = Left $ 192 | "syntax error at " ++ tokenPos ts ++ 193 | case ts of 194 | [] -> [] 195 | [Err _] -> " due to lexer error" 196 | t:_ -> " before `" ++ (prToken t) ++ "'" 197 | 198 | myLexer = tokens 199 | } 200 | 201 | -------------------------------------------------------------------------------- /src/Parser/Par.y.bak: -------------------------------------------------------------------------------- 1 | -- This Happy file was machine-generated by the BNF converter 2 | { 3 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} 4 | module Parser.Par 5 | ( happyError 6 | , myLexer 7 | , pProgram 8 | , pTerm4 9 | , pTerm3 10 | , pTerm2 11 | , pTerm1 12 | , pTerm 13 | , pLetVar 14 | , pListLetVar 15 | , pTup 16 | , pListTerm 17 | , pBit 18 | , pFunDec 19 | , pListFunDec 20 | , pFunction 21 | , pArg 22 | , pListArg 23 | , pType2 24 | , pType1 25 | , pType 26 | , pGate 27 | ) where 28 | import qualified Parser.Abs 29 | import Parser.Lex 30 | } 31 | 32 | %name pProgram Program 33 | %name pTerm4 Term4 34 | %name pTerm3 Term3 35 | %name pTerm2 Term2 36 | %name pTerm1 Term1 37 | %name pTerm Term 38 | %name pLetVar LetVar 39 | %name pListLetVar ListLetVar 40 | %name pTup Tup 41 | %name pListTerm ListTerm 42 | %name pBit Bit 43 | %name pFunDec FunDec 44 | %name pListFunDec ListFunDec 45 | %name pFunction Function 46 | %name pArg Arg 47 | %name pListArg ListArg 48 | %name pType2 Type2 49 | %name pType1 Type1 50 | %name pType Type 51 | %name pGate Gate 52 | -- no lexer declaration 53 | %monad { Either String } { (>>=) } { return } 54 | %tokentype {Token} 55 | %token 56 | '!' { PT _ (TS _ 1) } 57 | '$' { PT _ (TS _ 2) } 58 | '(' { PT _ (TS _ 3) } 59 | ')' { PT _ (TS _ 4) } 60 | '*' { PT _ (TS _ 5) } 61 | ',' { PT _ (TS _ 6) } 62 | '-o' { PT _ (TS _ 7) } 63 | '.' { PT _ (TS _ 8) } 64 | '=' { PT _ (TS _ 9) } 65 | '><' { PT _ (TS _ 10) } 66 | 'Bit' { PT _ (TS _ 11) } 67 | 'CNOT' { PT _ (TS _ 12) } 68 | 'FREDKIN' { PT _ (TS _ 13) } 69 | 'H' { PT _ (TS _ 14) } 70 | 'I' { PT _ (TS _ 15) } 71 | 'QBit' { PT _ (TS _ 16) } 72 | 'S' { PT _ (TS _ 17) } 73 | 'SWAP' { PT _ (TS _ 18) } 74 | 'T' { PT _ (TS _ 19) } 75 | 'TOFFOLI' { PT _ (TS _ 20) } 76 | 'X' { PT _ (TS _ 21) } 77 | 'Y' { PT _ (TS _ 22) } 78 | 'Z' { PT _ (TS _ 23) } 79 | 'else' { PT _ (TS _ 24) } 80 | 'if' { PT _ (TS _ 25) } 81 | 'in' { PT _ (TS _ 26) } 82 | 'let' { PT _ (TS _ 27) } 83 | 'then' { PT _ (TS _ 28) } 84 | L_integ { PT _ (TI $$) } 85 | L_FunVar { PT _ (T_FunVar $$) } 86 | L_Var { PT _ (T_Var $$) } 87 | L_GateIdent { PT _ (T_GateIdent $$) } 88 | L_Lambda { PT _ (T_Lambda $$) } 89 | 90 | %% 91 | 92 | Integer :: { Integer } 93 | Integer : L_integ { (read ($1)) :: Integer } 94 | 95 | FunVar :: { Parser.Abs.FunVar} 96 | FunVar : L_FunVar { Parser.Abs.FunVar $1 } 97 | 98 | Var :: { Parser.Abs.Var} 99 | Var : L_Var { Parser.Abs.Var $1 } 100 | 101 | GateIdent :: { Parser.Abs.GateIdent} 102 | GateIdent : L_GateIdent { Parser.Abs.GateIdent $1 } 103 | 104 | Lambda :: { Parser.Abs.Lambda} 105 | Lambda : L_Lambda { Parser.Abs.Lambda $1 } 106 | 107 | Program :: { Parser.Abs.Program } 108 | Program : ListFunDec { Parser.Abs.PDef $1 } 109 | 110 | Term4 :: { Parser.Abs.Term } 111 | Term4 : Var { Parser.Abs.TVar $1 } 112 | | Bit { Parser.Abs.TBit $1 } 113 | | Gate { Parser.Abs.TGate $1 } 114 | | Tup { Parser.Abs.TTup $1 } 115 | | '*' { Parser.Abs.TStar } 116 | | '(' Term ')' { $2 } 117 | 118 | Term3 :: { Parser.Abs.Term } 119 | Term3 : Term3 '$' Term4 { Parser.Abs.TDolr $1 $3 } | Term4 { $1 } 120 | 121 | Term2 :: { Parser.Abs.Term } 122 | Term2 : Term2 Term3 { Parser.Abs.TApp $1 $2 } | Term3 { $1 } 123 | 124 | Term1 :: { Parser.Abs.Term } 125 | Term1 : 'if' Term 'then' Term 'else' Term { Parser.Abs.TIfEl $2 $4 $6 } 126 | | 'let' '(' LetVar ',' ListLetVar ')' '=' Term 'in' Term { Parser.Abs.TLet $3 $5 $8 $10 } 127 | | Lambda FunVar Type '.' Term { Parser.Abs.TLamb $1 $2 $3 $5 } 128 | | Term2 { $1 } 129 | 130 | Term :: { Parser.Abs.Term } 131 | Term : Term1 { $1 } 132 | 133 | LetVar :: { Parser.Abs.LetVar } 134 | LetVar : Var { Parser.Abs.LVar $1 } 135 | 136 | ListLetVar :: { [Parser.Abs.LetVar] } 137 | ListLetVar : LetVar { (:[]) $1 } 138 | | LetVar ',' ListLetVar { (:) $1 $3 } 139 | 140 | Tup :: { Parser.Abs.Tup } 141 | Tup : '(' Term ',' ListTerm ')' { Parser.Abs.Tuple $2 $4 } 142 | 143 | ListTerm :: { [Parser.Abs.Term] } 144 | ListTerm : Term { (:[]) $1 } | Term ',' ListTerm { (:) $1 $3 } 145 | 146 | Bit :: { Parser.Abs.Bit } 147 | Bit : Integer { Parser.Abs.BBit $1 } 148 | 149 | FunDec :: { Parser.Abs.FunDec } 150 | FunDec : FunVar Type Function { Parser.Abs.FDecl $1 $2 $3 } 151 | 152 | ListFunDec :: { [Parser.Abs.FunDec] } 153 | ListFunDec : {- empty -} { [] } | FunDec ListFunDec { (:) $1 $2 } 154 | 155 | Function :: { Parser.Abs.Function } 156 | Function : Var ListArg '=' Term { Parser.Abs.FDef $1 $2 $4 } 157 | 158 | Arg :: { Parser.Abs.Arg } 159 | Arg : Var { Parser.Abs.FArg $1 } 160 | 161 | ListArg :: { [Parser.Abs.Arg] } 162 | ListArg : {- empty -} { [] } | Arg ListArg { (:) $1 $2 } 163 | 164 | Type2 :: { Parser.Abs.Type } 165 | Type2 : 'Bit' { Parser.Abs.TypeBit } 166 | | 'QBit' { Parser.Abs.TypeQbit } 167 | | 'T' { Parser.Abs.TypeUnit } 168 | | '!' Type2 { Parser.Abs.TypeDup $2 } 169 | | '(' Type ')' { $2 } 170 | 171 | Type1 :: { Parser.Abs.Type } 172 | Type1 : Type2 '><' Type1 { Parser.Abs.TypeTens $1 $3 } 173 | | Type2 '-o' Type1 { Parser.Abs.TypeFunc $1 $3 } 174 | | Type2 { $1 } 175 | 176 | Type :: { Parser.Abs.Type } 177 | Type : Type1 { $1 } 178 | 179 | Gate :: { Parser.Abs.Gate } 180 | Gate : 'H' { Parser.Abs.GH } 181 | | 'X' { Parser.Abs.GX } 182 | | 'Y' { Parser.Abs.GY } 183 | | 'Z' { Parser.Abs.GZ } 184 | | 'I' { Parser.Abs.GI } 185 | | 'S' { Parser.Abs.GS } 186 | | 'T' { Parser.Abs.GT } 187 | | 'CNOT' { Parser.Abs.GCNOT } 188 | | 'TOFFOLI' { Parser.Abs.GTOF } 189 | | 'SWAP' { Parser.Abs.GSWP } 190 | | 'FREDKIN' { Parser.Abs.GFRDK } 191 | | GateIdent { Parser.Abs.GIdent $1 } 192 | { 193 | 194 | happyError :: [Token] -> Either String a 195 | happyError ts = Left $ 196 | "syntax error at " ++ tokenPos ts ++ 197 | case ts of 198 | [] -> [] 199 | [Err _] -> " due to lexer error" 200 | t:_ -> " before `" ++ (prToken t) ++ "'" 201 | 202 | myLexer = tokens 203 | } 204 | 205 | -------------------------------------------------------------------------------- /src/Interpreter/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language FlexibleInstances #-} 3 | 4 | module Interpreter.Interpreter where 5 | 6 | import qualified Data.Map as M 7 | import Control.Monad.Except 8 | import Control.Monad.State 9 | ( StateT, MonadState(get), evalStateT, modify ) 10 | import FunQ 11 | import Lib.QM (link) 12 | import qualified AST.AST as A 13 | 14 | type Sig = M.Map String A.Term 15 | type FunctionValues = M.Map String Value 16 | type Eval = StateT FunctionValues QM 17 | 18 | -- | Environment type, stores bound variables & functions 19 | data Env = Env { 20 | values :: [Value] 21 | , functions :: Sig 22 | } deriving Show 23 | 24 | instance Show Value where 25 | show (VBit b) = show b 26 | show (VTup a b) = "⟨" ++ show a ++ "," ++ show b ++ "⟩" 27 | show (VQBit q) = "p" ++ show (link q) 28 | show VUnit = "*" 29 | show (VAbs _ t e) = show (A.Abs t e) 30 | show VNew = "new" 31 | show VMeas = "measure" 32 | show (VGate g) = show g 33 | 34 | -- | Return type 35 | data Value 36 | = VBit Bit 37 | | VQBit QBit 38 | | VUnit 39 | | VTup Value Value 40 | | VAbs [Value] A.Type A.Term 41 | | VNew 42 | | VMeas 43 | | VGate A.Gate 44 | 45 | -- | Main function in interpreter (exported) 46 | interpret :: [A.Function] -> QM Value 47 | interpret fs = evalStateT main M.empty 48 | where env = createEnv fs 49 | main = eval env (getTerm env "main") 50 | 51 | -- | Creates an environment from a list of functions. 52 | createEnv :: [A.Function] -> Env 53 | createEnv fs = Env { functions = M.fromList [(s, t) | (A.Func s _ t) <- fs], 54 | values = []} 55 | 56 | -- | Fetches a term from the environment 57 | getTerm :: Env -> String -> A.Term 58 | getTerm env name = let Just t = M.lookup name (functions env) in t 59 | 60 | -- | Term evaluator 61 | eval :: Env -> A.Term -> Eval Value 62 | eval env (A.Bit A.BZero) = return $ VBit 0 63 | eval env (A.Bit A.BOne) = return $ VBit 1 64 | eval env (A.Abs t e) = return $ VAbs (values env) t e 65 | eval env A.Unit = return VUnit 66 | eval env (A.Gate g) = return $ VGate g 67 | eval env A.New = return VNew 68 | eval env A.Meas = return VMeas 69 | 70 | eval env (A.Idx j) = return $ values env !! fromIntegral j 71 | 72 | eval env (A.Fun s) = do 73 | let t = getTerm env s 74 | fs <- get 75 | case M.lookup s fs of 76 | (Just v) -> return v 77 | Nothing -> do 78 | v <- eval env t 79 | modify (M.insert s v) 80 | return v 81 | 82 | eval env (A.Tup t1 t2) = do 83 | v1 <- eval env t1 84 | v2 <- eval env t2 85 | return $ VTup v1 v2 86 | 87 | eval env (A.App t1 t2) = 88 | case t1 of 89 | A.Gate g -> case g of 90 | A.GH -> runGate hadamard t2 env 91 | A.GX -> runGate pauliX t2 env 92 | A.GY -> runGate pauliY t2 env 93 | A.GZ -> runGate pauliZ t2 env 94 | A.GI -> runGate identity t2 env 95 | A.GT -> runGate phasePi8 t2 env 96 | A.GS -> runGate phase t2 env 97 | A.GCNOT -> run2Gate cnot t2 env 98 | A.GTOF -> run3Gate toffoli t2 env 99 | A.GSWP -> run2Gate swap t2 env 100 | A.GFRDK -> run3Gate fredkin t2 env 101 | A.GQFT n -> runQFT (qft n) t2 env 102 | A.GQFTI n -> runQFT (qftDagger n) t2 env 103 | A.GCR n -> run2Gate (`cphase` (1/(n*2))) t2 env 104 | A.GCRI n -> run2Gate (`cphase` (-1/(n*2))) t2 env 105 | A.GCCR n -> run3Gate (`ccphase` (1/(n*2))) t2 env 106 | A.GCCRI n -> run3Gate (`ccphase` (-1/(n*2))) t2 env 107 | 108 | A.New -> do 109 | VBit b' <- eval env t2 110 | lift $ VQBit <$> new b' 111 | A.Meas -> do 112 | VQBit q' <- eval env t2 113 | lift $ VBit <$> measure q' 114 | _ -> do 115 | v2 <- eval env t2 116 | v1 <- eval env t1 117 | case v1 of 118 | VAbs vs _ a -> eval env{ values = v2 : vs ++ values env } a 119 | VNew -> eval env{ values = v2 : values env } (A.App A.New (A.Idx 0)) 120 | VMeas -> eval env{ values = v2 : values env } (A.App A.Meas (A.Idx 0)) 121 | (VGate g) -> eval env{ values = v2 : values env } (A.App (A.Gate g) (A.Idx 0)) 122 | 123 | eval env (A.IfEl t t1 t2) = do 124 | VBit b <- eval env t 125 | eval env $ if b == 1 then t1 else t2 126 | 127 | eval env (A.Let eq inn) = do 128 | VTup v1 v2 <- eval env eq 129 | eval env{ values = v2 : v1 : values env } inn 130 | 131 | fromVTup :: Value -> [Value] 132 | fromVTup (VTup a b) = a : fromVTup b 133 | fromVTup x = [x] 134 | 135 | toVTup :: [Value] -> Value 136 | toVTup = foldr1 VTup 137 | 138 | -- | Run QFT gate 139 | runQFT :: ([QBit] -> QM [QBit]) -> A.Term -> Env -> Eval Value 140 | runQFT g q env = do 141 | res <- eval env q 142 | case res of 143 | (VQBit q') -> 144 | VQBit . head <$> lift (g [q']) 145 | vt@(VTup _ _) -> do 146 | b <- lift $ g (unValue (fromVTup vt)) 147 | return $ toVTup $ map VQBit b 148 | where unValue [] = [] 149 | unValue (VQBit q:qss) = q : unValue qss 150 | 151 | -- | Run gate taking one qubit 152 | runGate :: (QBit -> QM QBit) -> A.Term -> Env -> Eval Value 153 | runGate g q env = do 154 | VQBit q' <- eval env q 155 | VQBit <$> lift (g q') 156 | 157 | -- | Run gate taking two qubits 158 | run2Gate :: ((QBit, QBit) -> QM (QBit, QBit)) -> A.Term -> Env -> Eval Value 159 | run2Gate g q env = do 160 | VTup (VQBit a) (VQBit b) <- eval env q 161 | (p,q) <- lift (g (a,b)) 162 | return $ VTup (VQBit p) (VQBit q) 163 | 164 | -- | Run gate taking three qubits 165 | run3Gate :: ((QBit, QBit, QBit) -> QM (QBit, QBit, QBit)) -> A.Term -> Env -> Eval Value 166 | run3Gate g q env = do 167 | [VQBit a, VQBit b, VQBit c] <- fromVTup <$> eval env q 168 | toVTup . tupToList <$> lift (g (a,b,c)) 169 | where tupToList (a,b,c) = [VQBit a, VQBit b, VQBit c] -------------------------------------------------------------------------------- /src/SemanticAnalysis/SemanticAnalysis.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module SemanticAnalysis.SemanticAnalysis (runAnalysis, SemanticError(..)) where 4 | 5 | import Data.List 6 | import Parser.Abs 7 | import qualified Data.Set as Set 8 | import Data.Char ( digitToInt, isDigit, isLetter ) 9 | 10 | data SemanticError 11 | = FunNameMismatch String -- ^ Definition and function signature names must match 12 | | DuplicateFunction String -- ^ Function declared more than once 13 | | UnknownGate String -- ^ A gate that is not defined in the language was used 14 | | InvalidBit String -- ^ Bit must be 0 or 1 15 | | TooManyArguments String -- ^ Too many arguments in function definition 16 | 17 | instance Show SemanticError where 18 | show (FunNameMismatch e) = "Name mismatch in function " ++ e 19 | show (DuplicateFunction e) = "Duplicate definitions of function " ++ e 20 | show (UnknownGate e) = "Gate not recognized '" ++ e ++ "'" 21 | show (TooManyArguments e) = "Incorrect number of arguments in function " ++ e 22 | show (InvalidBit e) = "Expected 0 or 1, got " ++ e 23 | 24 | runAnalysis :: Program -> Either SemanticError () 25 | runAnalysis (PDef fs) = mapM_ ($ fs) [funNameMatch, dupFun, unknownGate, onlyBits, correctNumberOfArgs] 26 | 27 | -- | Checks that function name in type signature matches the name in function definition 28 | funNameMatch :: [FunDec] -> Either SemanticError () 29 | funNameMatch fs = checkSemantics fs isValid genErr errorMsg 30 | where isValid (FDecl (FunVar s) _ (FDef (Var s') _ _)) = funName' s == s' 31 | funName' s = takeUntil " " (takeUntil ":" s) 32 | genErr = FunNameMismatch 33 | errorMsg f = funName f 34 | 35 | -- | Checks that no functions are declared more than once 36 | dupFun :: [FunDec] -> Either SemanticError () 37 | dupFun fs = checkSemantics fs isValid genErr errorMsg 38 | where isValid f = length (filter (== funName f) funNames) == 1 39 | funNames = map funName fs 40 | genErr = DuplicateFunction 41 | errorMsg f = funName f 42 | 43 | -- | Checks that there are no unknown gates present. Primarly, this function checks gates 44 | -- | that are acceptable through the catch-all GateIdent term in the grammar. Typically, 45 | -- | gates that are included as such can not be easily specified without massive repitition 46 | -- | in the grammar or are generic (for instance the phase shift CR). 47 | unknownGate :: [FunDec] -> Either SemanticError () 48 | unknownGate fs = checkSemantics fs isValid genErr errorMsg 49 | where isValid (FDecl _ _ (FDef _ _ t)) = null (unknownGates t []) 50 | unknownGates :: Term -> [String] -> [String] 51 | unknownGates (TGate (GIdent (GateIdent g))) gs 52 | | init g == "QFT" && length g == 4 && digitToInt (last g) <= 5 = gs 53 | | init g == "QFTI" && length g == 5 && digitToInt (last g) <= 5 = gs 54 | | takeWhile isLetter g == "CR" && all isDigit (dropWhile isLetter g) && length g > 2 = gs 55 | | takeWhile isLetter g == "CRI" && all isDigit (dropWhile isLetter g) && length g > 3 = gs 56 | | takeWhile isLetter g == "CCR" && all isDigit (dropWhile isLetter g) && length g > 3 = gs 57 | | takeWhile isLetter g == "CCRI" && all isDigit (dropWhile isLetter g) && length g > 4 = gs 58 | | otherwise = gs ++ [g] 59 | unknownGates (TApp t1 t2) gs = gs ++ unknownGates t1 [] ++ unknownGates t2 [] 60 | unknownGates (TIfEl t1 t2 t3) gs = gs ++ unknownGates t1 [] ++ unknownGates t2 [] ++ unknownGates t3 [] 61 | unknownGates (TLet _ _ t1 t2) gs = gs ++ unknownGates t1 [] ++ unknownGates t2 [] 62 | unknownGates (TLamb _ _ _ t1) gs = gs ++ unknownGates t1 [] 63 | unknownGates _ gs = gs 64 | 65 | genErr = UnknownGate 66 | errorMsg (FDecl _ _ (FDef _ _ t)) = intercalate ", " $ unknownGates t [] 67 | 68 | -- | Checks that bits only are accept zero or ones. 69 | onlyBits :: [FunDec] -> Either SemanticError () 70 | onlyBits fs = checkSemantics fs isValid genErr errorMsg 71 | where isValid (FDecl _ _ (FDef _ _ t)) = null (invalidBit t []) 72 | invalidBit :: Term -> [String] -> [String] 73 | invalidBit (TBit (BBit n)) gs = if not (n == 0 || n == 1) then show n : gs else gs 74 | invalidBit (TApp t1 t2) gs = gs ++ invalidBit t1 [] ++ invalidBit t2 [] 75 | invalidBit (TIfEl t1 t2 t3) gs = gs ++ invalidBit t1 [] ++ invalidBit t2 [] ++ invalidBit t3 [] 76 | invalidBit (TLet _ _ t1 t2) gs = gs ++ invalidBit t1 [] ++ invalidBit t2 [] 77 | invalidBit (TLamb _ _ _ t1) gs = gs ++ invalidBit t1 [] 78 | invalidBit _ gs = gs 79 | genErr = InvalidBit 80 | errorMsg (FDecl _ _ (FDef _ _ t)) = intercalate ", " $ invalidBit t [] 81 | 82 | -- | Checks that not too many function arguments are used for function definition. 83 | correctNumberOfArgs :: [FunDec] -> Either SemanticError () 84 | correctNumberOfArgs fs = checkSemantics fs isValid genErr errorMsg 85 | where isValid (FDecl _ t (FDef _ args _)) = length args < size t 86 | size (TypeFunc t1 t2) = size t1 + size t2 87 | size (TypeTens t1 t2) = size t1 + size t2 88 | size (TypeDup t) = size t 89 | size _ = 1 90 | genErr = TooManyArguments 91 | errorMsg f@(FDecl _ t (FDef _ args _)) = "function " ++ funName f ++ " has " ++ show (length args) ++ " arguments but its type only has " ++ show (size t - 1) 92 | 93 | -- Utils 94 | -- | Iterates functions, checks given predicate and collects all errors, then 95 | -- | prints entire error. 96 | checkSemantics :: [FunDec] -> (FunDec -> Bool) -> (String -> SemanticError) -> (FunDec -> String) -> Either SemanticError () 97 | checkSemantics fs isValid err errMsg = if null errors then Right () else Left $ err errors 98 | where errors = intercalate ", " $ unique $ check fs [] 99 | check :: [FunDec] -> [String] -> [String] 100 | check [] ms = ms 101 | check (f:fs) ms = if isValid f then check fs ms else check fs (errMsg f : ms) 102 | unique = Set.toList . Set.fromList 103 | 104 | takeUntil :: String -> String -> String 105 | takeUntil _ [] = [] 106 | takeUntil [] _ = [] 107 | takeUntil xs (y:ys) = if isPrefixOf xs (y:ys) then [] else y:(takeUntil xs (tail (y:ys))) 108 | 109 | funName :: FunDec -> String 110 | funName (FDecl _ _ (FDef (Var s) _ _)) = s -------------------------------------------------------------------------------- /legacy/QData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE LiberalTypeSynonyms #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE BlockArguments #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE DerivingVia #-} 11 | {-# LANGUAGE Rank2Types #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 16 | {-# OPTIONS_HADDOCK not-home #-} 17 | 18 | {-| 19 | Module : QData 20 | Description : Basic datatypes and typeclasses 21 | Stability : experimental 22 | 23 | This is the core module of the language. This module contains the definitions 24 | of all the types exposed to the user. 25 | -} 26 | module QData 27 | ( -- * Core types 28 | QBit(..) 29 | , Bit(..) 30 | , Gate(..) 31 | , T 32 | 33 | -- * Product type 34 | , type (><) 35 | , Prod(..) 36 | 37 | -- * Helpers 38 | , bits 39 | , fromMatrix 40 | , i 41 | ) where 42 | 43 | import qualified Data.Bit as B (Bit (..)) 44 | import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (^), type(-)) 45 | import Numeric.LinearAlgebra (flatten, ident, kronecker, outer, toList) 46 | import qualified Numeric.LinearAlgebra as LA ((><)) 47 | import Numeric.LinearAlgebra.Static as V 48 | ( C, M, Sized(create, extract), Sq, (#>), mul, app ) 49 | import Prelude 50 | import GHC.Exts as E 51 | import Data.Bits 52 | import Foreign.Storable 53 | import qualified Data.Complex 54 | 55 | -- | The type of the quantum state. \(Q\) in \(\left[Q, L^*, \Lambda \right]\). 56 | type QState (d :: Nat) = C d 57 | 58 | 59 | -- | The product type family. Represents all types @Nat -> *@ that 60 | -- has a product operation, producing the sum of their type indexed size. 61 | type family (p :: b) >< (q :: b) :: b 62 | 63 | -- | Class `Prod` defines the product operation on sized types 64 | class Prod (p :: Nat -> *) where 65 | infixl 7 >< 66 | (><) :: (KnownNat n, KnownNat m, ((p n >< p m) ~ p (n + m))) => 67 | p n -> 68 | p m -> 69 | p n >< p m 70 | 71 | -- | Vector state representation of qubit state. 72 | -- Dependent on the number of bits @n@ where the vector becomes 73 | -- \[ \otimes_{i=0}^{n-1} \mathbb{C}^2 \]. 74 | -- The `QBit` type wraps a statically sized complex vector 75 | newtype QBit (n :: Nat) = Q { getState :: QState (2 ^ n) } 76 | deriving Show 77 | 78 | type instance (QBit n) >< (QBit m) = QBit (n + m) 79 | 80 | instance KnownNat n => Eq (QBit n) where 81 | (Q q) == (Q p) = extract q == extract p 82 | 83 | -- | The product type for QBits is defined as the tensor product 84 | instance Prod QBit where 85 | (Q p) >< (Q q) = Q 86 | let pv = extract p 87 | pq = extract q 88 | v = flatten $ outer pv pq 89 | in case create v of 90 | Just v' -> v' 91 | Nothing -> 92 | errorWithoutStackTrace $ 93 | "Incorrect vectors " ++ show p ++ " and " ++ show q 94 | 95 | -- | Type indexed bit strings. Should behave like a list of bits. 96 | data Bit (n :: Nat) where 97 | (:+) :: B.Bit -> Bit n -> Bit (n + 1) 98 | Sing :: B.Bit -> Bit 1 99 | 100 | infixr 6 :+ 101 | type instance (Bit n) >< (Bit m) = Bit (n + m) 102 | 103 | instance Show (Bit n) where 104 | show (Sing x) = show x 105 | show (x :+ xs) = show x ++ show xs 106 | 107 | -- | Ease of use case where a single bit string behaves like bit 108 | -- 109 | -- @ 110 | -- new 0 111 | -- -- instead of 112 | -- new (0 :+ NoBit) 113 | -- @ 114 | instance Num (Bit 1) where 115 | fromInteger x | x == 0 = Sing $ B.Bit False 116 | | x == 1 = Sing $ B.Bit True 117 | | otherwise = errorWithoutStackTrace "Cannot derive bits from non-binary values" 118 | (Sing a) * (Sing b) = Sing (a * b) 119 | (Sing a) + (Sing b) = Sing (a + b) 120 | (Sing a) - (Sing b) = Sing (a - b) 121 | negate = id 122 | abs = id 123 | signum = id 124 | 125 | -- | Ease of use case for pattern matching on single bits 126 | instance Eq (Bit 1) where 127 | (Sing a) == (Sing b) = a == b 128 | 129 | -- cc :: (KnownNat n, KnownNat m) => Bit n -> Bit m -> Bit (n + m) 130 | -- cc (Sing a) (Sing b) = a :+ Sing b 131 | -- cc (a :+ (as :: Bit (n - 1))) bs = a :+ (cc as bs) 132 | 133 | bits :: (Storable a, Bits a) => a -> [B.Bit] 134 | bits x = map (B.Bit . testBit x) [0..8*sizeOf x-1] 135 | 136 | -- | Matrix gate representation. 137 | -- Also wraps a function acting on the `QBit` type 138 | data Gate (n :: Nat) = Gate 139 | { matrix :: V.M (2^n) (2^n) 140 | , run :: QBit n -> QBit n 141 | } 142 | 143 | type instance (Gate n) >< (Gate m) = Gate (n + m) 144 | 145 | instance KnownNat n => Semigroup (Gate n) where 146 | Gate{matrix=a} <> Gate{matrix=b} = fromMatrix $ mul a b 147 | 148 | -- | The product type for Gates is defined as the kronecker product 149 | -- This combines the action of two gates, running in paralell 150 | -- 151 | -- >>> run (hadamard >< id) (new 0 >< new 0) 152 | -- Q {getState = (vector [0.7071067811865476,0.0,0.7071067811865476,0.0] :: R 4)} 153 | -- 154 | -- >>> run hadamard (new 0) >< run id (new 0) 155 | -- Q {getState = (vector [0.7071067811865476,0.0,0.7071067811865476,0.0] :: R 4)} 156 | instance Prod Gate where 157 | p >< q = fromMatrix 158 | let pm = extract $ matrix p 159 | qm = extract $ matrix q 160 | in case create $ pm `kronecker` qm of 161 | Just m -> m 162 | Nothing -> errorWithoutStackTrace 163 | $ "Incorrect matrices " ++ show p ++ " and " ++ show q 164 | 165 | -- | Converts a unitary matrix to the gate type 166 | fromMatrix :: KnownNat n => M (2^n) (2^n) -> Gate n 167 | fromMatrix mx = Gate 168 | { matrix = mx 169 | , run = \(Q q) -> Q $ app mx q 170 | } 171 | 172 | instance KnownNat n => Show (Gate n) where 173 | show Gate{matrix} = show matrix 174 | 175 | -- | The unit type \(* : \top\) 176 | type T = () 177 | 178 | -- | The imaginary unit 179 | i :: Data.Complex.Complex Double 180 | i = 0 Data.Complex.:+ 1 -------------------------------------------------------------------------------- /src/Lib/Gates.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-| 4 | Module : Gates 5 | Description : Gate library 6 | Stability : experimental 7 | 8 | Module containing unitary gates and their matrix representations. 9 | -} 10 | module Lib.Gates ( 11 | -- * Unitary gates 12 | pauliX 13 | , pauliY 14 | , pauliZ 15 | , hadamard 16 | , phase 17 | , phasePi8 18 | , cnot 19 | , identity 20 | , swap 21 | , tdagger 22 | , fredkin 23 | , toffoli 24 | , urot 25 | , crot 26 | , qft 27 | , qftDagger 28 | , cphase 29 | , ccphase 30 | ) where 31 | 32 | import Lib.Internal.Gates 33 | ( applyGate, 34 | applyParallel, 35 | ccontrolMatrix, 36 | changeAt, 37 | controlMatrix, 38 | i, 39 | notAdjacent, 40 | qftMatrix, 41 | runGate, 42 | hmat, 43 | phasemat, 44 | pXmat, 45 | pYmat, 46 | pZmat, 47 | idmat) 48 | import Lib.QM ( QM, QState(QState), QBit(..), getState, put, get ) 49 | import Numeric.LinearAlgebra 50 | ( Complex(..), (#>), (><), ident, kronecker, Matrix, Linear(scale), C, ident, tr ) 51 | 52 | -- | CNOT gate 53 | -- 54 | -- \[ \text{CNOT} = \begin{bmatrix} 55 | -- 1 & 0 & 0 & 0 \\ 56 | -- 0 & 1 & 0 & 0 \\ 57 | -- 0 & 0 & 0 & 1 \\ 58 | -- 0 & 0 & 1 & 0 59 | -- \end{bmatrix} 60 | -- \] 61 | -- 62 | -- ![cnot](images/cnot.PNG) 63 | cnot :: (QBit, QBit) -> QM (QBit, QBit) 64 | cnot (c, t) = do 65 | (_, size) <- getState 66 | let g = controlMatrix size c t pXmat 67 | applyGate g 68 | return (c,t) 69 | 70 | -- toffoli :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit) 71 | -- toffoli (c1,c2,t) = do 72 | -- (_, size) <- getState 73 | -- let matrixX = (2 >< 2) [ 0, 1, 1, 0 ] 74 | -- let g = ccontrolMatrix size c1 c2 t matrixX 75 | -- applyGate g 76 | -- return (c1,c2,t) 77 | 78 | -- | Toffoli gate 79 | -- 80 | -- \[ \begin{bmatrix} 81 | -- 1 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ 82 | -- 0 & 1 & 0 & 0 & 0 & 0 & 0 & 0 \\ 83 | -- 0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 \\ 84 | -- 0 & 0 & 0 & 1 & 0 & 0 & 0 & 0 \\ 85 | -- 0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 \\ 86 | -- 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 \\ 87 | -- 0 & 0 & 0 & 0 & 0 & 0 & 0 & 1 \\ 88 | -- 0 & 0 & 0 & 0 & 0 & 0 & 1 & 0 89 | -- \end{bmatrix} \] 90 | -- 91 | -- ![toffoli](images/toffoli.PNG) 92 | toffoli :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit) 93 | toffoli (c1,c2,t) = do 94 | (_, size) <- getState 95 | let g = ccontrolMatrix size c1 c2 t pXmat 96 | applyGate g 97 | return (c1,c2,t) 98 | 99 | -- | Pauli-X gate 100 | -- 101 | -- \[ \text{X} = \begin{bmatrix} 102 | -- 0 & 1 \\ 103 | -- 1 & 0 104 | -- \end{bmatrix} \] 105 | -- 106 | -- ![pauliX](images/x.PNG) 107 | pauliX :: QBit -> QM QBit 108 | pauliX = runGate pXmat 109 | 110 | -- | Pauli-Y gate 111 | -- 112 | -- \[ \text{Y} = \begin{bmatrix} 113 | -- 0 & -i \\ 114 | -- i & 0 115 | -- \end{bmatrix} \] 116 | -- 117 | -- ![pauliY](images/y.PNG) 118 | pauliY :: QBit -> QM QBit 119 | pauliY = runGate pYmat 120 | 121 | -- | Pauli-Z gate 122 | -- 123 | -- \[ \text{Z} = \begin{bmatrix} 124 | -- 1 & 0 \\ 125 | -- 0 & -1 126 | -- \end{bmatrix} \] 127 | -- 128 | -- ![pauliZ](images/z.PNG) 129 | pauliZ :: QBit -> QM QBit 130 | pauliZ = runGate pZmat 131 | 132 | -- | Hadamard gate 133 | -- 134 | -- \[ \text{X} = \frac1{\sqrt2} \begin{bmatrix} 135 | -- 1 & 1 \\ 136 | -- 1 & -1 137 | -- \end{bmatrix} \] 138 | -- 139 | -- ![hadamard](images/h.PNG) 140 | hadamard :: QBit -> QM QBit 141 | hadamard = runGate hmat 142 | 143 | -- | Phase gate 144 | -- 145 | -- \[ \text{S} = \begin{bmatrix} 146 | -- 1 & 0 \\ 147 | -- 0 & i 148 | -- \end{bmatrix} \] 149 | -- 150 | -- ![phase](images/s.PNG) 151 | phase :: QBit -> QM QBit 152 | phase = runGate $ phasemat (1/4) 153 | 154 | -- | Pi/8 gate (T gate) 155 | -- 156 | -- \[ \text{T} = \begin{bmatrix} 157 | -- 1 & 0 \\ 158 | -- 0 & e^{i\pi/4} 159 | -- \end{bmatrix} \] 160 | -- 161 | -- ![pi8](images/t.PNG) 162 | phasePi8 :: QBit -> QM QBit 163 | phasePi8 = runGate $ phasemat (1/8) 164 | 165 | -- | Hermetian adjoint of T gate (`phasePi8`) 166 | tdagger :: QBit -> QM QBit 167 | tdagger = runGate $ phasemat (-1/8) 168 | 169 | -- | Identity gate 170 | -- 171 | -- \[ \text{I} = \begin{bmatrix} 172 | -- 1 & 0 \\ 173 | -- 0 & 1 174 | -- \end{bmatrix} \] 175 | -- 176 | 177 | cphase :: (QBit, QBit) -> Double -> QM (QBit, QBit) 178 | cphase (c, t) p = do 179 | (_, size) <- getState 180 | let g = controlMatrix size c t (phasemat (p :: Double)) 181 | applyGate g 182 | return (c,t) 183 | 184 | ccphase :: (QBit, QBit,QBit) -> Double -> QM (QBit,QBit, QBit) 185 | ccphase (c1,c2,t) p = do 186 | (_, size) <- getState 187 | let g = ccontrolMatrix size c1 c2 t (phasemat (p :: Double)) 188 | applyGate g 189 | return (c1,c2,t) 190 | 191 | identity :: QBit -> QM QBit 192 | identity = runGate idmat 193 | 194 | -- | SWAP gate 195 | -- 196 | -- \[ \text{SWAP} = \begin{bmatrix} 197 | -- 1 & 0 & 0 & 0 \\ 198 | -- 0 & 0 & 1 & 0 \\ 199 | -- 0 & 1 & 0 & 0 \\ 200 | -- 0 & 0 & 0 & 1 201 | -- \end{bmatrix} 202 | -- \] 203 | -- 204 | -- ![swap](images/swap.PNG) 205 | swap :: (QBit, QBit) -> QM (QBit, QBit) 206 | swap (p,q) = do 207 | cnot (p,q) 208 | cnot (q,p) 209 | cnot (p,q) 210 | 211 | -- | Fredkin gate 212 | fredkin :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit) 213 | fredkin (c,p,q) = do 214 | cnot (q,p) 215 | toffoli (c,p,q) 216 | cnot (q,p) 217 | return (c,p,q) 218 | 219 | -- | UROT gate 220 | urot :: Int -> QBit -> QM QBit 221 | urot k = runGate $ (2 >< 2) 222 | [ 1, 0, 223 | 0, p ] 224 | where p = exp ((2*pi*i) / (2^k)) 225 | 226 | -- | Controlled UROT 227 | crot :: Int -> (QBit, QBit) -> QM (QBit, QBit) 228 | crot k (c, t) = do 229 | (_, size) <- getState 230 | let p = exp ((2*pi*i) / (2^k)) 231 | let matrixRot = (2 >< 2) [ 1, 0, 0, p ] 232 | let g = controlMatrix size c t matrixRot 233 | applyGate g 234 | return (c,t) 235 | 236 | -- | Quantum fourier transform 237 | qft :: Int -> [QBit] -> QM [QBit] 238 | qft _ [] = errorWithoutStackTrace "Cannot perform QFT on zero qubits" 239 | qft n qs@((Ptr q):_) 240 | | notAdjacent (map link qs) = 241 | errorWithoutStackTrace "Cannot perform QFT on non-adjacent qubits" 242 | | otherwise = do 243 | (_, size) <- getState 244 | let matrixQFT = qftMatrix (2 ^ n) 245 | let ids = replicate (size - n + 1) (ident 2) 246 | let masqwe = changeAt matrixQFT q ids 247 | applyGate $ foldr1 applyParallel masqwe 248 | return qs 249 | 250 | -- | Inverse quantum fourier transform 251 | qftDagger :: Int -> [QBit] -> QM [QBit] 252 | qftDagger _ [] = errorWithoutStackTrace "Cannot perform QFT on zero qubits" 253 | qftDagger n qs@((Ptr q):_) 254 | | notAdjacent (map link qs) = 255 | errorWithoutStackTrace "Cannot perform QFT on non-adjacent qubits" 256 | | otherwise = do 257 | (_, size) <- getState 258 | let matrixQFT = tr $ qftMatrix (2 ^ n) 259 | let ids = replicate (size - n + 1) (ident 2) 260 | let masqwe = changeAt matrixQFT q ids 261 | applyGate $ foldr1 applyParallel masqwe 262 | return qs 263 | -------------------------------------------------------------------------------- /src/Parser/Lex.x: -------------------------------------------------------------------------------- 1 | -- -*- haskell -*- 2 | -- This Alex file was machine-generated by the BNF converter 3 | { 4 | {-# OPTIONS -fno-warn-incomplete-patterns #-} 5 | {-# OPTIONS_GHC -w #-} 6 | module Parser.Lex where 7 | 8 | import qualified Data.Bits 9 | import Data.Word (Word8) 10 | import Data.Char (ord) 11 | } 12 | 13 | 14 | $c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter (215 = \times) FIXME 15 | $s = [a-z\222-\255] # [\247] -- small isolatin1 letter (247 = \div ) FIXME 16 | $l = [$c $s] -- letter 17 | $d = [0-9] -- digit 18 | $i = [$l $d _ '] -- identifier character 19 | $u = [. \n] -- universal: any character 20 | 21 | @rsyms = -- symbols and non-identifier-like reserved words 22 | \* | \( | \, | \) | \= | \. | \$ | \! | \> \< | \- "o" 23 | 24 | :- 25 | 26 | -- Line comments 27 | "--" [.]* ; 28 | 29 | -- Block comments 30 | \{ \- [$u # \-]* \- ([$u # [\- \}]] [$u # \-]* \- | \-)* \} ; 31 | 32 | $white+ ; 33 | @rsyms 34 | { tok (\p s -> PT p (eitherResIdent TV s)) } 35 | $s ([\' \_]| ($d | $l)) * \ * \: 36 | { tok (\p s -> PT p (eitherResIdent T_FunVar s)) } 37 | $s ([\' \_]| ($d | $l)) * 38 | { tok (\p s -> PT p (eitherResIdent T_Var s)) } 39 | $c ($d | $c)* 40 | { tok (\p s -> PT p (eitherResIdent T_GateIdent s)) } 41 | \\ 42 | { tok (\p s -> PT p (eitherResIdent T_Lambda s)) } 43 | 44 | $l $i* 45 | { tok (\p s -> PT p (eitherResIdent TV s)) } 46 | 47 | 48 | $d+ 49 | { tok (\p s -> PT p (TI s)) } 50 | 51 | 52 | { 53 | 54 | tok :: (Posn -> String -> Token) -> (Posn -> String -> Token) 55 | tok f p s = f p s 56 | 57 | data Tok = 58 | TS !String !Int -- reserved words and symbols 59 | | TL !String -- string literals 60 | | TI !String -- integer literals 61 | | TV !String -- identifiers 62 | | TD !String -- double precision float literals 63 | | TC !String -- character literals 64 | | T_FunVar !String 65 | | T_Var !String 66 | | T_GateIdent !String 67 | | T_Lambda !String 68 | 69 | deriving (Eq,Show,Ord) 70 | 71 | data Token = 72 | PT Posn Tok 73 | | Err Posn 74 | deriving (Eq,Show,Ord) 75 | 76 | printPosn :: Posn -> String 77 | printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c 78 | 79 | tokenPos :: [Token] -> String 80 | tokenPos (t:_) = printPosn (tokenPosn t) 81 | tokenPos [] = "end of file" 82 | 83 | tokenPosn :: Token -> Posn 84 | tokenPosn (PT p _) = p 85 | tokenPosn (Err p) = p 86 | 87 | tokenLineCol :: Token -> (Int, Int) 88 | tokenLineCol = posLineCol . tokenPosn 89 | 90 | posLineCol :: Posn -> (Int, Int) 91 | posLineCol (Pn _ l c) = (l,c) 92 | 93 | mkPosToken :: Token -> ((Int, Int), String) 94 | mkPosToken t@(PT p _) = (posLineCol p, tokenText t) 95 | 96 | tokenText :: Token -> String 97 | tokenText t = case t of 98 | PT _ (TS s _) -> s 99 | PT _ (TL s) -> show s 100 | PT _ (TI s) -> s 101 | PT _ (TV s) -> s 102 | PT _ (TD s) -> s 103 | PT _ (TC s) -> s 104 | Err _ -> "#error" 105 | PT _ (T_FunVar s) -> s 106 | PT _ (T_Var s) -> s 107 | PT _ (T_GateIdent s) -> s 108 | PT _ (T_Lambda s) -> s 109 | 110 | prToken :: Token -> String 111 | prToken t = tokenText t 112 | 113 | data BTree = N | B String Tok BTree BTree deriving (Show) 114 | 115 | eitherResIdent :: (String -> Tok) -> String -> Tok 116 | eitherResIdent tv s = treeFind resWords 117 | where 118 | treeFind N = tv s 119 | treeFind (B a t left right) | s < a = treeFind left 120 | | s > a = treeFind right 121 | | s == a = t 122 | 123 | resWords :: BTree 124 | resWords = b "I" 15 (b "." 8 (b ")" 4 (b "$" 2 (b "!" 1 N N) (b "(" 3 N N)) (b "," 6 (b "*" 5 N N) (b "-o" 7 N N))) (b "CNOT" 12 (b "><" 10 (b "=" 9 N N) (b "Bit" 11 N N)) (b "H" 14 (b "FREDKIN" 13 N N) N))) (b "Y" 22 (b "T" 19 (b "S" 17 (b "QBit" 16 N N) (b "SWAP" 18 N N)) (b "X" 21 (b "TOFFOLI" 20 N N) N)) (b "in" 26 (b "else" 24 (b "Z" 23 N N) (b "if" 25 N N)) (b "then" 28 (b "let" 27 N N) N))) 125 | where b s n = let bs = s 126 | in B bs (TS bs n) 127 | 128 | unescapeInitTail :: String -> String 129 | unescapeInitTail = id . unesc . tail . id 130 | where 131 | unesc s = case s of 132 | '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs 133 | '\\':'n':cs -> '\n' : unesc cs 134 | '\\':'t':cs -> '\t' : unesc cs 135 | '\\':'r':cs -> '\r' : unesc cs 136 | '\\':'f':cs -> '\f' : unesc cs 137 | '"':[] -> [] 138 | c:cs -> c : unesc cs 139 | _ -> [] 140 | 141 | ------------------------------------------------------------------- 142 | -- Alex wrapper code. 143 | -- A modified "posn" wrapper. 144 | ------------------------------------------------------------------- 145 | 146 | data Posn = Pn !Int !Int !Int 147 | deriving (Eq, Show,Ord) 148 | 149 | alexStartPos :: Posn 150 | alexStartPos = Pn 0 1 1 151 | 152 | alexMove :: Posn -> Char -> Posn 153 | alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) 154 | alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 155 | alexMove (Pn a l c) _ = Pn (a+1) l (c+1) 156 | 157 | type Byte = Word8 158 | 159 | type AlexInput = (Posn, -- current position, 160 | Char, -- previous char 161 | [Byte], -- pending bytes on the current char 162 | String) -- current input string 163 | 164 | tokens :: String -> [Token] 165 | tokens str = go (alexStartPos, '\n', [], str) 166 | where 167 | go :: AlexInput -> [Token] 168 | go inp@(pos, _, _, str) = 169 | case alexScan inp 0 of 170 | AlexEOF -> [] 171 | AlexError (pos, _, _, _) -> [Err pos] 172 | AlexSkip inp' len -> go inp' 173 | AlexToken inp' len act -> act pos (take len str) : (go inp') 174 | 175 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 176 | alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) 177 | alexGetByte (p, _, [], s) = 178 | case s of 179 | [] -> Nothing 180 | (c:s) -> 181 | let p' = alexMove p c 182 | (b:bs) = utf8Encode c 183 | in p' `seq` Just (b, (p', c, bs, s)) 184 | 185 | alexInputPrevChar :: AlexInput -> Char 186 | alexInputPrevChar (p, c, bs, s) = c 187 | 188 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 189 | utf8Encode :: Char -> [Word8] 190 | utf8Encode = map fromIntegral . go . ord 191 | where 192 | go oc 193 | | oc <= 0x7f = [oc] 194 | 195 | | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) 196 | , 0x80 + oc Data.Bits..&. 0x3f 197 | ] 198 | 199 | | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) 200 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 201 | , 0x80 + oc Data.Bits..&. 0x3f 202 | ] 203 | | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) 204 | , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) 205 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 206 | , 0x80 + oc Data.Bits..&. 0x3f 207 | ] 208 | } 209 | -------------------------------------------------------------------------------- /src/Parser/Lex.x.bak: -------------------------------------------------------------------------------- 1 | -- -*- haskell -*- 2 | -- This Alex file was machine-generated by the BNF converter 3 | { 4 | {-# OPTIONS -fno-warn-incomplete-patterns #-} 5 | {-# OPTIONS_GHC -w #-} 6 | module Parser.Lex where 7 | 8 | import qualified Data.Bits 9 | import Data.Word (Word8) 10 | import Data.Char (ord) 11 | } 12 | 13 | 14 | $c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter (215 = \times) FIXME 15 | $s = [a-z\222-\255] # [\247] -- small isolatin1 letter (247 = \div ) FIXME 16 | $l = [$c $s] -- letter 17 | $d = [0-9] -- digit 18 | $i = [$l $d _ '] -- identifier character 19 | $u = [. \n] -- universal: any character 20 | 21 | @rsyms = -- symbols and non-identifier-like reserved words 22 | \* | \$ | \( | \, | \) | \= | \. | \! | \> \< | \- "o" 23 | 24 | :- 25 | 26 | -- Line comments 27 | "--" [.]* ; 28 | 29 | -- Block comments 30 | \{ \- [$u # \-]* \- ([$u # [\- \}]] [$u # \-]* \- | \-)* \} ; 31 | 32 | $white+ ; 33 | @rsyms 34 | { tok (\p s -> PT p (eitherResIdent TV s)) } 35 | $s ([\' \_]| ($d | $l)) * \ * \: 36 | { tok (\p s -> PT p (eitherResIdent T_FunVar s)) } 37 | $s ([\' \_]| ($d | $l)) * 38 | { tok (\p s -> PT p (eitherResIdent T_Var s)) } 39 | $c ($d | $c)* 40 | { tok (\p s -> PT p (eitherResIdent T_GateIdent s)) } 41 | \\ 42 | { tok (\p s -> PT p (eitherResIdent T_Lambda s)) } 43 | 44 | $l $i* 45 | { tok (\p s -> PT p (eitherResIdent TV s)) } 46 | 47 | 48 | $d+ 49 | { tok (\p s -> PT p (TI s)) } 50 | 51 | 52 | { 53 | 54 | tok :: (Posn -> String -> Token) -> (Posn -> String -> Token) 55 | tok f p s = f p s 56 | 57 | data Tok = 58 | TS !String !Int -- reserved words and symbols 59 | | TL !String -- string literals 60 | | TI !String -- integer literals 61 | | TV !String -- identifiers 62 | | TD !String -- double precision float literals 63 | | TC !String -- character literals 64 | | T_FunVar !String 65 | | T_Var !String 66 | | T_GateIdent !String 67 | | T_Lambda !String 68 | 69 | deriving (Eq,Show,Ord) 70 | 71 | data Token = 72 | PT Posn Tok 73 | | Err Posn 74 | deriving (Eq,Show,Ord) 75 | 76 | printPosn :: Posn -> String 77 | printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c 78 | 79 | tokenPos :: [Token] -> String 80 | tokenPos (t:_) = printPosn (tokenPosn t) 81 | tokenPos [] = "end of file" 82 | 83 | tokenPosn :: Token -> Posn 84 | tokenPosn (PT p _) = p 85 | tokenPosn (Err p) = p 86 | 87 | tokenLineCol :: Token -> (Int, Int) 88 | tokenLineCol = posLineCol . tokenPosn 89 | 90 | posLineCol :: Posn -> (Int, Int) 91 | posLineCol (Pn _ l c) = (l,c) 92 | 93 | mkPosToken :: Token -> ((Int, Int), String) 94 | mkPosToken t@(PT p _) = (posLineCol p, tokenText t) 95 | 96 | tokenText :: Token -> String 97 | tokenText t = case t of 98 | PT _ (TS s _) -> s 99 | PT _ (TL s) -> show s 100 | PT _ (TI s) -> s 101 | PT _ (TV s) -> s 102 | PT _ (TD s) -> s 103 | PT _ (TC s) -> s 104 | Err _ -> "#error" 105 | PT _ (T_FunVar s) -> s 106 | PT _ (T_Var s) -> s 107 | PT _ (T_GateIdent s) -> s 108 | PT _ (T_Lambda s) -> s 109 | 110 | prToken :: Token -> String 111 | prToken t = tokenText t 112 | 113 | data BTree = N | B String Tok BTree BTree deriving (Show) 114 | 115 | eitherResIdent :: (String -> Tok) -> String -> Tok 116 | eitherResIdent tv s = treeFind resWords 117 | where 118 | treeFind N = tv s 119 | treeFind (B a t left right) | s < a = treeFind left 120 | | s > a = treeFind right 121 | | s == a = t 122 | 123 | resWords :: BTree 124 | resWords = b "I" 15 (b "." 8 (b ")" 4 (b "$" 2 (b "!" 1 N N) (b "(" 3 N N)) (b "," 6 (b "*" 5 N N) (b "-o" 7 N N))) (b "CNOT" 12 (b "><" 10 (b "=" 9 N N) (b "Bit" 11 N N)) (b "H" 14 (b "FREDKIN" 13 N N) N))) (b "Y" 22 (b "T" 19 (b "S" 17 (b "QBit" 16 N N) (b "SWAP" 18 N N)) (b "X" 21 (b "TOFFOLI" 20 N N) N)) (b "in" 26 (b "else" 24 (b "Z" 23 N N) (b "if" 25 N N)) (b "then" 28 (b "let" 27 N N) N))) 125 | where b s n = let bs = s 126 | in B bs (TS bs n) 127 | 128 | unescapeInitTail :: String -> String 129 | unescapeInitTail = id . unesc . tail . id 130 | where 131 | unesc s = case s of 132 | '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs 133 | '\\':'n':cs -> '\n' : unesc cs 134 | '\\':'t':cs -> '\t' : unesc cs 135 | '\\':'r':cs -> '\r' : unesc cs 136 | '\\':'f':cs -> '\f' : unesc cs 137 | '"':[] -> [] 138 | c:cs -> c : unesc cs 139 | _ -> [] 140 | 141 | ------------------------------------------------------------------- 142 | -- Alex wrapper code. 143 | -- A modified "posn" wrapper. 144 | ------------------------------------------------------------------- 145 | 146 | data Posn = Pn !Int !Int !Int 147 | deriving (Eq, Show,Ord) 148 | 149 | alexStartPos :: Posn 150 | alexStartPos = Pn 0 1 1 151 | 152 | alexMove :: Posn -> Char -> Posn 153 | alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) 154 | alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 155 | alexMove (Pn a l c) _ = Pn (a+1) l (c+1) 156 | 157 | type Byte = Word8 158 | 159 | type AlexInput = (Posn, -- current position, 160 | Char, -- previous char 161 | [Byte], -- pending bytes on the current char 162 | String) -- current input string 163 | 164 | tokens :: String -> [Token] 165 | tokens str = go (alexStartPos, '\n', [], str) 166 | where 167 | go :: AlexInput -> [Token] 168 | go inp@(pos, _, _, str) = 169 | case alexScan inp 0 of 170 | AlexEOF -> [] 171 | AlexError (pos, _, _, _) -> [Err pos] 172 | AlexSkip inp' len -> go inp' 173 | AlexToken inp' len act -> act pos (take len str) : (go inp') 174 | 175 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 176 | alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) 177 | alexGetByte (p, _, [], s) = 178 | case s of 179 | [] -> Nothing 180 | (c:s) -> 181 | let p' = alexMove p c 182 | (b:bs) = utf8Encode c 183 | in p' `seq` Just (b, (p', c, bs, s)) 184 | 185 | alexInputPrevChar :: AlexInput -> Char 186 | alexInputPrevChar (p, c, bs, s) = c 187 | 188 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 189 | utf8Encode :: Char -> [Word8] 190 | utf8Encode = map fromIntegral . go . ord 191 | where 192 | go oc 193 | | oc <= 0x7f = [oc] 194 | 195 | | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) 196 | , 0x80 + oc Data.Bits..&. 0x3f 197 | ] 198 | 199 | | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) 200 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 201 | , 0x80 + oc Data.Bits..&. 0x3f 202 | ] 203 | | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) 204 | , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) 205 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 206 | , 0x80 + oc Data.Bits..&. 0x3f 207 | ] 208 | } 209 | -------------------------------------------------------------------------------- /app/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | 4 | module Repl where 5 | 6 | import qualified Interpreter.Run as Run 7 | import Interpreter.Interpreter hiding ( eval ) 8 | import Type.TypeChecker hiding ( throwError, linenv ) 9 | import System.Console.Haskeline 10 | import System.Console.Repline 11 | import Control.Monad.IO.Class 12 | import Control.Monad.State 13 | import Control.Monad.Except 14 | import Control.Monad.Catch 15 | import Data.List 16 | import Data.Maybe 17 | import Data.Char 18 | import Data.Functor 19 | import Paths_qfunc 20 | import Text.Read 21 | import Data.Version 22 | import Text.Read (readMaybe) 23 | import AST.AST 24 | import Text.Parsec 25 | ( alphaNum, 26 | space, 27 | string, 28 | manyTill, 29 | parse, 30 | skipMany, 31 | ParsecT, 32 | Stream ) 33 | import qualified Data.Map as Map 34 | import qualified Data.Set as Set 35 | 36 | -- type Repl = HaskelineT (StateT ReplState (ExceptT Run.Error IO)) 37 | type Repl = HaskelineT (StateT ReplState IO) 38 | 39 | data Assign = Assign String Type Value 40 | deriving Show 41 | 42 | data ReplState = RS 43 | { funs :: Set.Set Function 44 | , linenv :: LinEnv 45 | } deriving Show 46 | 47 | emptyRS :: ReplState 48 | emptyRS = RS Set.empty Set.empty 49 | 50 | emptyFun :: String -> Function 51 | emptyFun n = Func n TypeUnit Unit 52 | 53 | err :: Show e => Either e v -> Repl v 54 | err (Left e) = errorWithoutStackTrace $ "*** Exception, " ++ show e 55 | err (Right v) = return v 56 | 57 | buildLin :: LinEnv -> ErrorEnv 58 | buildLin s = ErrorEnv s "" 59 | 60 | printr :: MonadIO io => String -> io () 61 | printr = liftIO . putStrLn 62 | 63 | getfun :: String -> Repl (Maybe (Term, Type)) 64 | getfun name = gets $ (\env -> lookup name [(n,(e,t)) | Func n t e <- env]) . (Set.toList . funs) 65 | 66 | ops :: [(String, String -> Repl ())] 67 | ops = [ ("help" , helpCmd ) 68 | , ("?" , helpCmd ) 69 | , ("quit" , quitCmd ) 70 | , ("run" , runCmd ) 71 | , ("version", verCmd ) 72 | , ("type" , typeCmd ) 73 | , ("env" , envCmd ) 74 | , ("load" , loadCmd ) 75 | , ("clear" , clearCmd) 76 | , ("delete" , delCmd ) 77 | , ("ml" , return . return ()) 78 | ] 79 | 80 | helpTexts :: Map.Map String String 81 | helpTexts = Map.fromList 82 | [ ("quit", "\nQuit the session") 83 | , ("run", "FILEPATH [RUNS]\nRun a file") 84 | , ("?", "[COMMAND]\nShow help") 85 | , ("help", "[COMMAND]\nShow help") 86 | , ("ml", "\nEnter multiline mode") 87 | , ("version", "\nShow version") 88 | , ("type", "[EXPRESSION]\nShow the type of an expression. No arguments shows the types in the environment.") 89 | , ("env", "\nShow environment") 90 | , ("load", "\nLoad a file into the environment") 91 | , ("clear", "\nClear the environment") 92 | , ("delete", "\nDelete a function from the environment") 93 | ] 94 | 95 | helpCmd :: String -> Repl () 96 | helpCmd [] = printr $ "Available commands:\n" 97 | ++ intercalate "\n" [fst x | x <- ops] 98 | ++ "\n\nFor info on a specific command type :help COMMAND (or :? COMMAND)" 99 | helpCmd arg = case Map.lookup arg helpTexts of 100 | Nothing -> printr $ "-- no such command: " ++ arg 101 | Just help -> printr $ "Usage: " ++ arg ++ " " ++ help 102 | 103 | quitCmd, runCmd, verCmd, typeCmd, envCmd, loadCmd, clearCmd, delCmd :: String -> Repl () 104 | quitCmd _ = abort 105 | runCmd paths = case words paths of 106 | [p] -> liftIO $ Run.runReplIO p 107 | [p,r] -> liftIO $ maybe (putStrLn "invalid arguments") (Run.rundistRepl p) (readMaybe r) 108 | _ -> printr "-- invalid arguments" 109 | verCmd _ = printr $ showVersion version 110 | typeCmd "" = mapM_ (printr . showType) =<< gets funs 111 | where showType (Func n t _) = n ++ " : " ++ show t 112 | typeCmd n = gets (Set.toList . funs) 113 | >>= \env -> either (printr . show) (printr . show) 114 | $ runCheckWith (infer (parseExp n)) (buildTopEnv env) (buildLin Set.empty) 115 | envCmd _ = mapM_ (printr . show) =<< gets funs 116 | loadCmd path = mapM_ (dontCrash . load) (words path) 117 | where fnames = Set.map (\(Func n _ _) -> n) 118 | load s = liftIO (Run.checkProgram s) 119 | >>= modify 120 | . (\prog (RS env lin) -> 121 | RS (Set.union prog env) (Set.difference lin (fnames prog))) 122 | . Set.delete (emptyFun "main") . Set.fromList 123 | clearCmd _ = put emptyRS 124 | delCmd name = modify \(RS env lin) -> RS (Set.delete (emptyFun name) env) (Set.delete name lin) 125 | 126 | parseAssign :: Stream s m Char => ParsecT s u m [Char] 127 | parseAssign = manyTill alphaNum (skipMany space >> string "=") 128 | 129 | evalCmd :: String -> Repl () 130 | evalCmd line = case parse parseAssign "" line of 131 | Left _ -> do 132 | env <- gets (Set.toList . funs) 133 | lin <- gets linenv 134 | let term = Run.parseExp line 135 | typ <- err $ runCheckWith (infer term) (buildTopEnv env) (buildLin lin) 136 | (mval, mtyp) <- err =<< liftIO (runExceptT (Run.runProgram $ Func "main" typ term : env)) 137 | addLinears term 138 | printr $ show mval ++ " : " ++ show mtyp 139 | Right "main" -> printr "-- cannot define main function in interactive environment" 140 | Right name -> do 141 | let termString = tail $ dropWhile (/='=') line 142 | term = Run.parseExp termString 143 | env <- gets funs 144 | lin <- gets linenv 145 | case runCheckWith (infer term) (buildTopEnv (Set.toList env)) (buildLin lin) of 146 | Left err -> errorWithoutStackTrace $ "*** Exception, " ++ show err 147 | Right typ -> modify (\s -> s{funs=Set.insert (Func name typ term) env}) 148 | >> when (Set.member (Func name typ term) env) 149 | (modify \s -> s{linenv=Set.delete name lin}) 150 | 151 | addLinears :: Term -> Repl () 152 | addLinears term = do 153 | env <- gets funs 154 | ts <- map snd . catMaybes <$> mapM getfun (names term) 155 | let ns = map fst $ filter (isLinear . snd) $ zip (names term) ts 156 | lin <- gets linenv 157 | modify $ \s -> s{linenv = Set.union (Set.fromList ns) lin} 158 | 159 | compl :: WordCompleter (StateT ReplState IO) 160 | compl n = do 161 | env <- gets (Set.toList . funs) 162 | return $ filter (isPrefixOf n) 163 | $ map ((':':) . fst) ops 164 | ++ [n | Func n _ _ <- env] 165 | ++ ["new", "meas", "measure"] 166 | 167 | mainWith :: ReplState -> IO () 168 | mainWith rs = flip evalStateT rs $ evalReplOpts $ ReplOpts 169 | { banner = const (pure "λ ") 170 | , command = dontCrash . evalCmd 171 | , options = ops 172 | , prefix = Just ':' 173 | , multilineCommand = Just "ml" 174 | , tabComplete = Combine (Word compl) File 175 | , initialiser = printr $ "funQ " ++ showVersion version ++ "\n:? for help" 176 | , finaliser = printr "Leaving funQ." $> Exit 177 | } 178 | 179 | mainFile :: String -> IO () 180 | mainFile path = liftIO (Run.checkProgram path) 181 | >>= (mainWith . flip RS Set.empty) 182 | . Set.delete (emptyFun "main") 183 | . Set.fromList 184 | 185 | main :: IO () 186 | main = mainWith emptyRS -------------------------------------------------------------------------------- /src/Parser/Print.hs.bak: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ <= 708 3 | {-# LANGUAGE OverlappingInstances #-} 4 | #endif 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 7 | 8 | -- | Pretty-printer for Parser. 9 | -- Generated by the BNF converter. 10 | 11 | module Parser.Print where 12 | 13 | import qualified Parser.Abs 14 | import Data.Char 15 | 16 | -- | The top-level printing method. 17 | 18 | printTree :: Print a => a -> String 19 | printTree = render . prt 0 20 | 21 | type Doc = [ShowS] -> [ShowS] 22 | 23 | doc :: ShowS -> Doc 24 | doc = (:) 25 | 26 | render :: Doc -> String 27 | render d = rend 0 (map ($ "") $ d []) "" where 28 | rend i ss = case ss of 29 | "[" :ts -> showChar '[' . rend i ts 30 | "(" :ts -> showChar '(' . rend i ts 31 | "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts 32 | "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts 33 | "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts 34 | [";"] -> showChar ';' 35 | ";" :ts -> showChar ';' . new i . rend i ts 36 | t : ts@(p:_) | closingOrPunctuation p -> showString t . rend i ts 37 | t :ts -> space t . rend i ts 38 | _ -> id 39 | new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace 40 | space t s = 41 | case (all isSpace t', null spc, null rest) of 42 | (True , _ , True ) -> [] -- remove trailing space 43 | (False, _ , True ) -> t' -- remove trailing space 44 | (False, True, False) -> t' ++ ' ' : s -- add space if none 45 | _ -> t' ++ s 46 | where 47 | t' = showString t [] 48 | (spc, rest) = span isSpace s 49 | 50 | closingOrPunctuation :: String -> Bool 51 | closingOrPunctuation [c] = c `elem` closerOrPunct 52 | closingOrPunctuation _ = False 53 | 54 | closerOrPunct :: String 55 | closerOrPunct = ")],;" 56 | 57 | parenth :: Doc -> Doc 58 | parenth ss = doc (showChar '(') . ss . doc (showChar ')') 59 | 60 | concatS :: [ShowS] -> ShowS 61 | concatS = foldr (.) id 62 | 63 | concatD :: [Doc] -> Doc 64 | concatD = foldr (.) id 65 | 66 | replicateS :: Int -> ShowS -> ShowS 67 | replicateS n f = concatS (replicate n f) 68 | 69 | -- | The printer class does the job. 70 | 71 | class Print a where 72 | prt :: Int -> a -> Doc 73 | prtList :: Int -> [a] -> Doc 74 | prtList i = concatD . map (prt i) 75 | 76 | instance {-# OVERLAPPABLE #-} Print a => Print [a] where 77 | prt = prtList 78 | 79 | instance Print Char where 80 | prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') 81 | prtList _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') 82 | 83 | mkEsc :: Char -> Char -> ShowS 84 | mkEsc q s = case s of 85 | _ | s == q -> showChar '\\' . showChar s 86 | '\\'-> showString "\\\\" 87 | '\n' -> showString "\\n" 88 | '\t' -> showString "\\t" 89 | _ -> showChar s 90 | 91 | prPrec :: Int -> Int -> Doc -> Doc 92 | prPrec i j = if j < i then parenth else id 93 | 94 | instance Print Integer where 95 | prt _ x = doc (shows x) 96 | 97 | instance Print Double where 98 | prt _ x = doc (shows x) 99 | 100 | instance Print Parser.Abs.FunVar where 101 | prt _ (Parser.Abs.FunVar i) = doc $ showString $ i 102 | 103 | instance Print Parser.Abs.Var where 104 | prt _ (Parser.Abs.Var i) = doc $ showString $ i 105 | 106 | instance Print Parser.Abs.GateIdent where 107 | prt _ (Parser.Abs.GateIdent i) = doc $ showString $ i 108 | 109 | instance Print Parser.Abs.Lambda where 110 | prt _ (Parser.Abs.Lambda i) = doc $ showString $ i 111 | 112 | instance Print Parser.Abs.Program where 113 | prt i e = case e of 114 | Parser.Abs.PDef fundecs -> prPrec i 0 (concatD [prt 0 fundecs]) 115 | 116 | instance Print Parser.Abs.Term where 117 | prt i e = case e of 118 | Parser.Abs.TVar var -> prPrec i 4 (concatD [prt 0 var]) 119 | Parser.Abs.TBit bit -> prPrec i 4 (concatD [prt 0 bit]) 120 | Parser.Abs.TGate gate -> prPrec i 4 (concatD [prt 0 gate]) 121 | Parser.Abs.TTup tup -> prPrec i 4 (concatD [prt 0 tup]) 122 | Parser.Abs.TStar -> prPrec i 4 (concatD [doc (showString "*")]) 123 | Parser.Abs.TDolr term1 term2 -> prPrec i 3 (concatD [prt 3 term1, doc (showString "$"), prt 4 term2]) 124 | Parser.Abs.TApp term1 term2 -> prPrec i 2 (concatD [prt 2 term1, prt 3 term2]) 125 | Parser.Abs.TIfEl term1 term2 term3 -> prPrec i 1 (concatD [doc (showString "if"), prt 0 term1, doc (showString "then"), prt 0 term2, doc (showString "else"), prt 0 term3]) 126 | Parser.Abs.TLet letvar letvars term1 term2 -> prPrec i 1 (concatD [doc (showString "let"), doc (showString "("), prt 0 letvar, doc (showString ","), prt 0 letvars, doc (showString ")"), doc (showString "="), prt 0 term1, doc (showString "in"), prt 0 term2]) 127 | Parser.Abs.TLamb lambda funvar type_ term -> prPrec i 1 (concatD [prt 0 lambda, prt 0 funvar, prt 0 type_, doc (showString "."), prt 0 term]) 128 | prtList _ [x] = concatD [prt 0 x] 129 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] 130 | 131 | instance Print Parser.Abs.LetVar where 132 | prt i e = case e of 133 | Parser.Abs.LVar var -> prPrec i 0 (concatD [prt 0 var]) 134 | prtList _ [x] = concatD [prt 0 x] 135 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] 136 | 137 | instance Print [Parser.Abs.LetVar] where 138 | prt = prtList 139 | 140 | instance Print Parser.Abs.Tup where 141 | prt i e = case e of 142 | Parser.Abs.Tuple term terms -> prPrec i 0 (concatD [doc (showString "("), prt 0 term, doc (showString ","), prt 0 terms, doc (showString ")")]) 143 | 144 | instance Print [Parser.Abs.Term] where 145 | prt = prtList 146 | 147 | instance Print Parser.Abs.Bit where 148 | prt i e = case e of 149 | Parser.Abs.BBit n -> prPrec i 0 (concatD [prt 0 n]) 150 | 151 | instance Print Parser.Abs.FunDec where 152 | prt i e = case e of 153 | Parser.Abs.FDecl funvar type_ function -> prPrec i 0 (concatD [prt 0 funvar, prt 0 type_, prt 0 function]) 154 | prtList _ [] = concatD [] 155 | prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs] 156 | 157 | instance Print [Parser.Abs.FunDec] where 158 | prt = prtList 159 | 160 | instance Print Parser.Abs.Function where 161 | prt i e = case e of 162 | Parser.Abs.FDef var args term -> prPrec i 0 (concatD [prt 0 var, prt 0 args, doc (showString "="), prt 0 term]) 163 | 164 | instance Print Parser.Abs.Arg where 165 | prt i e = case e of 166 | Parser.Abs.FArg var -> prPrec i 0 (concatD [prt 0 var]) 167 | prtList _ [] = concatD [] 168 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] 169 | 170 | instance Print [Parser.Abs.Arg] where 171 | prt = prtList 172 | 173 | instance Print Parser.Abs.Type where 174 | prt i e = case e of 175 | Parser.Abs.TypeBit -> prPrec i 2 (concatD [doc (showString "Bit")]) 176 | Parser.Abs.TypeQbit -> prPrec i 2 (concatD [doc (showString "QBit")]) 177 | Parser.Abs.TypeUnit -> prPrec i 2 (concatD [doc (showString "T")]) 178 | Parser.Abs.TypeDup type_ -> prPrec i 2 (concatD [doc (showString "!"), prt 2 type_]) 179 | Parser.Abs.TypeTens type_1 type_2 -> prPrec i 1 (concatD [prt 2 type_1, doc (showString "><"), prt 1 type_2]) 180 | Parser.Abs.TypeFunc type_1 type_2 -> prPrec i 1 (concatD [prt 2 type_1, doc (showString "-o"), prt 1 type_2]) 181 | 182 | instance Print Parser.Abs.Gate where 183 | prt i e = case e of 184 | Parser.Abs.GH -> prPrec i 0 (concatD [doc (showString "H")]) 185 | Parser.Abs.GX -> prPrec i 0 (concatD [doc (showString "X")]) 186 | Parser.Abs.GY -> prPrec i 0 (concatD [doc (showString "Y")]) 187 | Parser.Abs.GZ -> prPrec i 0 (concatD [doc (showString "Z")]) 188 | Parser.Abs.GI -> prPrec i 0 (concatD [doc (showString "I")]) 189 | Parser.Abs.GS -> prPrec i 0 (concatD [doc (showString "S")]) 190 | Parser.Abs.GT -> prPrec i 0 (concatD [doc (showString "T")]) 191 | Parser.Abs.GCNOT -> prPrec i 0 (concatD [doc (showString "CNOT")]) 192 | Parser.Abs.GTOF -> prPrec i 0 (concatD [doc (showString "TOFFOLI")]) 193 | Parser.Abs.GSWP -> prPrec i 0 (concatD [doc (showString "SWAP")]) 194 | Parser.Abs.GFRDK -> prPrec i 0 (concatD [doc (showString "FREDKIN")]) 195 | Parser.Abs.GIdent gateident -> prPrec i 0 (concatD [prt 0 gateident]) 196 | 197 | -------------------------------------------------------------------------------- /src/Parser/Print.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ <= 708 3 | {-# LANGUAGE OverlappingInstances #-} 4 | #endif 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 7 | 8 | -- | Pretty-printer for Parser. 9 | -- Generated by the BNF converter. 10 | 11 | module Parser.Print where 12 | 13 | import qualified Parser.Abs 14 | import Data.Char 15 | 16 | -- | The top-level printing method. 17 | 18 | printTree :: Print a => a -> String 19 | printTree = render . prt 0 20 | 21 | type Doc = [ShowS] -> [ShowS] 22 | 23 | doc :: ShowS -> Doc 24 | doc = (:) 25 | 26 | render :: Doc -> String 27 | render d = rend 0 (map ($ "") $ d []) "" where 28 | rend i ss = case ss of 29 | "[" :ts -> showChar '[' . rend i ts 30 | "(" :ts -> showChar '(' . rend i ts 31 | "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts 32 | "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts 33 | "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts 34 | [";"] -> showChar ';' 35 | ";" :ts -> showChar ';' . new i . rend i ts 36 | t : ts@(p:_) | closingOrPunctuation p -> showString t . rend i ts 37 | t :ts -> space t . rend i ts 38 | _ -> id 39 | new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace 40 | space t s = 41 | case (all isSpace t' || t' == "!", null spc, null rest) of 42 | (True , _ , True ) -> [] -- remove trailing space 43 | (False, _ , True ) -> t' -- remove trailing space 44 | (False, True, False) -> t' ++ ' ' : s -- add space if none 45 | _ -> t' ++ s 46 | where 47 | t' = showString t [] 48 | (spc, rest) = span isSpace s 49 | 50 | closingOrPunctuation :: String -> Bool 51 | closingOrPunctuation [c] = c `elem` closerOrPunct 52 | closingOrPunctuation _ = False 53 | 54 | closerOrPunct :: String 55 | closerOrPunct = ")],;" 56 | 57 | parenth :: Doc -> Doc 58 | parenth ss = doc (showChar '(') . ss . doc (showChar ')') 59 | 60 | concatS :: [ShowS] -> ShowS 61 | concatS = foldr (.) id 62 | 63 | concatD :: [Doc] -> Doc 64 | concatD = foldr (.) id 65 | 66 | replicateS :: Int -> ShowS -> ShowS 67 | replicateS n f = concatS (replicate n f) 68 | 69 | -- | The printer class does the job. 70 | 71 | class Print a where 72 | prt :: Int -> a -> Doc 73 | prtList :: Int -> [a] -> Doc 74 | prtList i = concatD . map (prt i) 75 | 76 | instance {-# OVERLAPPABLE #-} Print a => Print [a] where 77 | prt = prtList 78 | 79 | instance Print Char where 80 | prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') 81 | prtList _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') 82 | 83 | mkEsc :: Char -> Char -> ShowS 84 | mkEsc q s = case s of 85 | _ | s == q -> showChar '\\' . showChar s 86 | '\\'-> showString "\\\\" 87 | '\n' -> showString "\\n" 88 | '\t' -> showString "\\t" 89 | _ -> showChar s 90 | 91 | prPrec :: Int -> Int -> Doc -> Doc 92 | prPrec i j = if j < i then parenth else id 93 | 94 | instance Print Integer where 95 | prt _ x = doc (shows x) 96 | 97 | instance Print Double where 98 | prt _ x = doc (shows x) 99 | 100 | instance Print Parser.Abs.FunVar where 101 | prt _ (Parser.Abs.FunVar i) = doc $ showString $ i 102 | 103 | instance Print Parser.Abs.Var where 104 | prt _ (Parser.Abs.Var i) = doc $ showString $ i 105 | 106 | instance Print Parser.Abs.GateIdent where 107 | prt _ (Parser.Abs.GateIdent i) = doc $ showString $ i 108 | 109 | instance Print Parser.Abs.Lambda where 110 | prt _ (Parser.Abs.Lambda i) = doc $ showString $ "λ" 111 | 112 | instance Print Parser.Abs.Program where 113 | prt i e = case e of 114 | Parser.Abs.PDef fundecs -> prPrec i 0 (concatD [prt 0 fundecs]) 115 | 116 | instance Print Parser.Abs.Term where 117 | prt i e = case e of 118 | Parser.Abs.TVar var -> prPrec i 3 (concatD [prt 0 var]) 119 | Parser.Abs.TBit bit -> prPrec i 3 (concatD [prt 0 bit]) 120 | Parser.Abs.TGate gate -> prPrec i 3 (concatD [prt 0 gate]) 121 | Parser.Abs.TTup tup -> prPrec i 3 (concatD [prt 0 tup]) 122 | Parser.Abs.TStar -> prPrec i 3 (concatD [doc (showString "*")]) 123 | Parser.Abs.TDolr term1 term2 -> prPrec i 2 (concatD [prt 2 term1, doc (showString "$"), prt 3 term2]) 124 | Parser.Abs.TApp term1 term2 -> prPrec i 2 (concatD [prt 2 term1, prt 3 term2]) 125 | Parser.Abs.TIfEl term1 term2 term3 -> prPrec i 1 (concatD [doc (showString "if"), prt 2 term1, doc (showString "then"), prt 0 term2, doc (showString "else"), prt 0 term3]) 126 | Parser.Abs.TLet letvar letvars term1 term2 -> prPrec i 1 (concatD [doc (showString "let"), doc (showString "("), prt 0 letvar, doc (showString ","), prt 0 letvars, doc (showString ")"), doc (showString "="), prt 0 term1, doc (showString "in"), prt 0 term2]) 127 | Parser.Abs.TLamb lambda funvar type_ term -> prPrec i 1 (concatD [prt 0 lambda, prt 0 funvar, doc (showString ":"), prt 0 type_, doc (showString "."), prt 0 term]) 128 | prtList _ [x] = concatD [prt 0 x] 129 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] 130 | 131 | instance Print Parser.Abs.LetVar where 132 | prt i e = case e of 133 | Parser.Abs.LVar var -> prPrec i 0 (concatD [prt 0 var]) 134 | prtList _ [x] = concatD [prt 0 x] 135 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] 136 | 137 | instance Print [Parser.Abs.LetVar] where 138 | prt = prtList 139 | 140 | instance Print Parser.Abs.Tup where 141 | prt i e = case e of 142 | Parser.Abs.Tuple term terms -> prPrec i 0 (concatD [doc (showString "⟨"), prt 0 term, doc (showString ","), prt 0 terms, doc (showString "⟩")]) 143 | 144 | instance Print [Parser.Abs.Term] where 145 | prt = prtList 146 | 147 | instance Print Parser.Abs.Bit where 148 | prt i e = case e of 149 | Parser.Abs.BBit n -> prPrec i 0 (concatD [prt 0 n]) 150 | 151 | instance Print Parser.Abs.FunDec where 152 | prt i e = case e of 153 | Parser.Abs.FDecl funvar type_ function -> prPrec i 0 (concatD [prt 0 funvar, prt 0 type_, prt 0 function]) 154 | prtList _ [] = concatD [] 155 | prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs] 156 | 157 | instance Print [Parser.Abs.FunDec] where 158 | prt = prtList 159 | 160 | instance Print Parser.Abs.Function where 161 | prt i e = case e of 162 | Parser.Abs.FDef var args term -> prPrec i 0 (concatD [prt 0 var, prt 0 args, doc (showString "="), prt 0 term]) 163 | 164 | instance Print Parser.Abs.Arg where 165 | prt i e = case e of 166 | Parser.Abs.FArg var -> prPrec i 0 (concatD [prt 0 var]) 167 | prtList _ [] = concatD [] 168 | prtList _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] 169 | 170 | instance Print [Parser.Abs.Arg] where 171 | prt = prtList 172 | 173 | instance Print Parser.Abs.Type where 174 | prt i e = case e of 175 | Parser.Abs.TypeBit -> prPrec i 2 (concatD [doc (showString "Bit")]) 176 | Parser.Abs.TypeQbit -> prPrec i 2 (concatD [doc (showString "QBit")]) 177 | Parser.Abs.TypeUnit -> prPrec i 2 (concatD [doc (showString "⊤")]) 178 | Parser.Abs.TypeDup type_ -> prPrec i 2 (concatD [doc (showString "!"), prt 2 type_]) 179 | Parser.Abs.TypeTens type_1 type_2 -> prPrec i 1 (concatD [prt 2 type_1, doc (showString "⊗"), prt 1 type_2]) 180 | Parser.Abs.TypeFunc type_1 type_2 -> prPrec i 1 (concatD [prt 2 type_1, doc (showString "⊸"), prt 1 type_2]) 181 | 182 | instance Print Parser.Abs.Gate where 183 | prt i e = case e of 184 | Parser.Abs.GH -> prPrec i 0 (concatD [doc (showString "H")]) 185 | Parser.Abs.GX -> prPrec i 0 (concatD [doc (showString "X")]) 186 | Parser.Abs.GY -> prPrec i 0 (concatD [doc (showString "Y")]) 187 | Parser.Abs.GZ -> prPrec i 0 (concatD [doc (showString "Z")]) 188 | Parser.Abs.GI -> prPrec i 0 (concatD [doc (showString "I")]) 189 | Parser.Abs.GS -> prPrec i 0 (concatD [doc (showString "S")]) 190 | Parser.Abs.GT -> prPrec i 0 (concatD [doc (showString "T")]) 191 | Parser.Abs.GCNOT -> prPrec i 0 (concatD [doc (showString "CNOT")]) 192 | Parser.Abs.GTOF -> prPrec i 0 (concatD [doc (showString "TOFFOLI")]) 193 | Parser.Abs.GSWP -> prPrec i 0 (concatD [doc (showString "SWAP")]) 194 | Parser.Abs.GFRDK -> prPrec i 0 (concatD [doc (showString "FREDKIN")]) 195 | Parser.Abs.GIdent gateident -> prPrec i 0 (concatD [prt 0 gateident]) 196 | 197 | -------------------------------------------------------------------------------- /src/Interpreter/Run.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Interpreter.Run where 4 | 5 | import qualified FunQ as Q 6 | import qualified AST.AST as A 7 | import Parser.Par (pProgram, myLexer) 8 | import qualified Interpreter.Interpreter as I 9 | import System.Console.Haskeline 10 | import Control.Monad.Except 11 | ( MonadIO(liftIO), 12 | MonadTrans(lift), 13 | MonadError(throwError), 14 | ExceptT(..), 15 | mapExceptT, 16 | runExceptT, 17 | withExceptT, replicateM, zipWithM ) 18 | import Data.Bifunctor ( Bifunctor(bimap, first) ) 19 | import Control.Exception (Exception, try) 20 | import qualified Type.TypeChecker as TC 21 | import Data.List 22 | import Data.Maybe 23 | import Control.Monad.State.Lazy 24 | import System.Exit 25 | import Parser.Abs 26 | import qualified SemanticAnalysis.SemanticAnalysis as S 27 | 28 | type Run a = ExceptT Error IO a 29 | 30 | data Error 31 | = ParseError String 32 | | SemanticError S.SemanticError 33 | | TypeError TC.TypeError 34 | | NoSuchFile FilePath 35 | 36 | instance Exception Error 37 | 38 | instance Show Error where 39 | show (SemanticError e) = 40 | "semantic error:\n" ++ show e 41 | 42 | show (ParseError e) = 43 | "syntax error:\n" ++ e 44 | 45 | show (TypeError (TC.TError where' why)) = 46 | "type error in function " ++ where' ++ ":\n" ++ show why 47 | 48 | show (NoSuchFile f) = 49 | "file not found: " ++ f 50 | 51 | -- | Runs funq on a file. 52 | runIO :: FilePath -> IO () 53 | runIO path = runExceptT (check path) >>= \case 54 | Left e -> putStrLn ("*** Exception, " ++ show e) >> exitFailure 55 | Right fs -> if "main" `elem` fnames fs 56 | then either (\e -> print e >> exitFailure) print =<< runExceptT (eval fs) 57 | else putStrLn "*** Note:\nstatic analysis passed, no main function defined" 58 | 59 | runReplIO :: FilePath -> IO () 60 | runReplIO path = runExceptT (check path) >>= \case 61 | Left e -> putStrLn ("*** Exception, " ++ show e) 62 | Right fs -> if "main" `elem` fnames fs 63 | then either print print =<< runExceptT (eval fs) 64 | else putStrLn "*** Note:\nstatic analysis passed, no main function defined" 65 | 66 | runTerminalIO :: String -> IO () 67 | runTerminalIO s = runExceptT (runTerminal s) >>= \case 68 | Left err -> putStrLn $ "*** Exception, " ++ show err 69 | Right (v,t) -> putStrLn $ show v ++ " : " ++ show t 70 | 71 | runTerminal :: String -> Run (I.Value, A.Type) 72 | runTerminal s = do 73 | p@[A.Func _ _ term] <- convertAST =<< semanticAnalysis =<< parse s 74 | typ <- toErr (TC.runCheck . TC.infer) TypeError id term 75 | val <- eval p 76 | return (val, typ) 77 | 78 | readfile :: FilePath -> Run String 79 | readfile path = do 80 | e <- liftIO (try (readFile path) :: IO (Either IOError String)) 81 | case e of 82 | Left _ -> throwError $ NoSuchFile path 83 | Right s -> return s 84 | 85 | parse :: String -> Run Program 86 | parse = toErr (pProgram . myLexer) ParseError id 87 | 88 | run :: String -> Run I.Value 89 | run s = parse s >>= semanticAnalysis >>= convertAST >>= typecheck >>= eval 90 | 91 | -- Components 92 | convertAST :: Program -> Run A.Program 93 | convertAST = return . A.toIm 94 | 95 | typecheck :: A.Program -> Run A.Program 96 | typecheck = toErr TC.typecheck TypeError . const <*> id 97 | 98 | eval :: A.Program -> Run I.Value 99 | eval p = liftIO (Q.run $ I.interpret p) 100 | 101 | semanticAnalysis :: Program -> Run Program 102 | semanticAnalysis = toErr S.runAnalysis SemanticError . const <*> id 103 | 104 | runProgram :: A.Program -> Run (I.Value, A.Type) 105 | runProgram p = do 106 | typecheck p 107 | val <- eval p 108 | typ <- case lookup "main" [(n,t) | A.Func n t _ <- p] of 109 | Just t -> return t 110 | return (val, typ) 111 | 112 | parseExp :: [Char] -> A.Term 113 | parseExp e = either semanticerror (const (fetchTerm (A.toIm prog))) (S.runAnalysis prog) 114 | where prog = either syntaxerror id $ pProgram (myLexer ("main : T main = " ++ e)) 115 | fetchTerm [A.Func _ _ t] = t 116 | syntaxerror e = errorWithoutStackTrace $ "*** Exception:\n" ++ e 117 | semanticerror e = errorWithoutStackTrace $ "*** Exception, semantic error:\n" ++ show e 118 | 119 | checkProgram :: FilePath -> IO A.Program 120 | checkProgram path = runExceptT (readfile path >>= parse >>= semanticAnalysis >>= convertAST >>= typecheck) >>= \case 121 | Left e -> errorWithoutStackTrace $ "*** Exception, " ++ show e 122 | Right p -> return p 123 | 124 | check :: FilePath -> Run A.Program 125 | check path = readfile path 126 | >>= parse 127 | >>= semanticAnalysis 128 | >>= convertAST 129 | >>= typecheck 130 | 131 | -- Utils 132 | fnames :: A.Program -> [String] 133 | fnames = map (\(A.Func n _ _) -> n) 134 | 135 | toErr :: (i -> Either e v) -> (e -> Error) -> (v -> o) -> i -> Run o 136 | toErr f l r = ExceptT . return . bimap l r . f 137 | 138 | -- | Distribution runs of programs 139 | rundistest :: FilePath -> Int -> IO () 140 | rundistest path runs = runExceptT (check path) >>= \case 141 | Left e -> putStrLn ("*** Exception, " ++ show e) >> exitFailure 142 | Right fs -> if "main" `elem` fnames fs 143 | then either (\e -> print e >> exitFailure) gatherResults =<< runExceptT (evaldist fs runs) 144 | else putStrLn "*** Note:\nstatic analysis passed, no main function defined" 145 | 146 | rundistRepl :: FilePath -> Int -> IO () 147 | rundistRepl path runs = runExceptT (check path) >>= \case 148 | Left e -> putStrLn ("*** Exception, " ++ show e) 149 | Right fs -> if "main" `elem` fnames fs 150 | then either print gatherResults =<< runExceptT (evaldist fs runs) 151 | else putStrLn "*** Note:\nstatic analysis passed, no main function defined" 152 | 153 | rundist :: FilePath -> Int -> Run [I.Value] 154 | rundist path runs = readfile path 155 | >>= parse 156 | >>= semanticAnalysis 157 | >>= convertAST 158 | >>= typecheck 159 | >>= flip evaldist runs 160 | 161 | evaldist :: A.Program -> Int -> Run [I.Value] 162 | evaldist prg reps = replicateM reps $ eval prg 163 | 164 | gatherResults :: [I.Value] -> IO () 165 | gatherResults vals = mapM_ (putStrLn . prettystats nbits) stats 166 | where lengthV :: I.Value -> Int 167 | lengthV (I.VBit b) = 1 168 | lengthV (I.VTup _ v) = 1 + lengthV v 169 | nbits = lengthV $ head vals 170 | stats = stat (length vals) (countUniques $ map readtup vals) 171 | 172 | readtup :: I.Value -> Int 173 | readtup = toDec . catchBit . reverse . I.fromVTup 174 | where catchBit [] = [] 175 | catchBit (I.VBit b:bs) = (fromIntegral . toInteger) b : catchBit bs 176 | toDec [] = 0 177 | toDec (b:bs) = b + 2*toDec bs 178 | 179 | countUniques :: [Int] -> [(Int, Int)] 180 | countUniques as = zip (sort (findUniques as [])) (countOcc as) 181 | where findUniques [] as = as 182 | findUniques (b:bs) as = if b `elem` as then findUniques bs as else findUniques bs (insert b as) 183 | countOcc as = map length $ (group . sort) as 184 | 185 | stat :: Int -> [(Int, Int)] -> [(Int, Double, Int)] 186 | stat _ [] = [] 187 | stat len ((a,b):as) = (a, dub b/dub len, b) : stat len as 188 | where dub = fromIntegral . toInteger 189 | 190 | prettystats :: Int -> (Int, Double, Int) -> String 191 | prettystats len (a,b,c) = concatMap show ((fillzeros len . toBin) a) ++ ": " ++ "\t" ++ (show . truncateboi) b ++ "%" ++ "\t" ++ show c 192 | where truncateboi d = (fromIntegral . truncate) (10000*(d :: Double))/100 193 | 194 | toBin :: Int -> [Int] 195 | toBin 0 = [] 196 | toBin n | n `mod` 2 == 1 = toBin (n `div` 2) ++ [1] 197 | toBin n | even n = toBin (n `div` 2) ++ [0] 198 | 199 | fillzeros :: Int -> [Int] -> [Int] 200 | fillzeros len as = if length as == len then as else replicate (len - length as) 0 ++ as 201 | 202 | -- | Run program with auto-generated inputs 203 | runNewInputs :: FilePath -> IO () 204 | runNewInputs path = do 205 | file <- readFile path 206 | let ixs = inds file 207 | res <- runExceptT $ mapM (evalNewInputs ixs file) [0..7] 208 | case res of 209 | Left err -> putStrLn $ "*** Exception, " ++ show err 210 | Right r -> gatherGenResults [0..7] r 211 | 212 | evalNewInputs :: [Int] -> String -> Int -> Run I.Value 213 | evalNewInputs ixs prg inputNr = do 214 | let newfile = updateIns 0 ixs (inputsNew 3 !! inputNr) prg in parse newfile >>= semanticAnalysis >>= convertAST >>= typecheck >>= eval 215 | 216 | updateIns :: Int -> [Int] -> [String] -> String -> String 217 | updateIns _ [] _ prg = prg 218 | updateIns n (ix:ixs) (input:inputs) prg 219 | | n == ix = updateIns (n+1) (map (+1) ixs) inputs (replaceIx prgs (ix + 1) input) 220 | | otherwise = updateIns (n+1) (ix:ixs) (input:inputs) prg 221 | where prgs = words prg 222 | 223 | replaceIx :: [String] -> Int -> String -> String 224 | replaceIx list ix val = let (a,b) = splitAt ix list in 225 | let elem = last a in unwords $ take (ix-1) a ++ mend elem val : b 226 | where mend elem val 227 | | head elem == '(' = '(' : val ++ "," 228 | | last elem == ')' = val ++ ")" 229 | | otherwise = val ++ "," 230 | 231 | inds :: String -> [Int] 232 | inds l = findIndices predN (words l) 233 | where predN :: String -> Bool 234 | predN s = let clean = filter (\x -> x `elem` ['a'..'z'] || x `elem` ['1'..'9']) s in 235 | clean `elem` ins 236 | ins = ["in" ++ show a | a <- [1..9]] 237 | 238 | inputsNew :: Int -> [[String]] 239 | inputsNew len = let bins = map (fillzeros len . toBin) [0..2^len-1] in [map ((++) "new " . show) a | a <- bins] 240 | 241 | prettyPrintGens :: Int -> (Int,Int) -> String 242 | prettyPrintGens len (ein, aus) = show einB ++ "\t" ++ show ausB 243 | where einB = fillzeros len . toBin $ ein 244 | ausB = fillzeros len . toBin $ aus 245 | 246 | gatherGenResults :: [Int] -> [I.Value] -> IO () 247 | gatherGenResults ins outs = do 248 | let nbits = lengthV $ head outs 249 | let res = map readtup outs 250 | let terms = zip ins res 251 | putStrLn $ " in " ++ "\t" ++ "result" 252 | mapM_ (putStrLn . prettyPrintGens nbits) terms 253 | where lengthV :: I.Value -> Int 254 | lengthV (I.VBit b) = 1 255 | lengthV (I.VTup _ v) = 1 + lengthV v 256 | -------------------------------------------------------------------------------- /src/AST/AST.hs: -------------------------------------------------------------------------------- 1 | module AST.AST 2 | ( -- * Base types 3 | Program 4 | , Function(..) 5 | , Term(..) 6 | , Type(..) 7 | , AST.AST.Gate(..) 8 | 9 | -- * Term functions 10 | , toIm 11 | 12 | -- * Type functions 13 | , convertType 14 | 15 | -- * Run functions 16 | , runFile 17 | , run 18 | , reverseType 19 | , AST.AST.Bit(..) 20 | ) 21 | where 22 | 23 | import Parser.Par ( myLexer, pProgram ) 24 | import Parser.Print ( printTree ) 25 | import qualified Parser.Abs as P 26 | import qualified Data.Map as M 27 | import Data.Char 28 | 29 | type Env = M.Map String Integer 30 | 31 | -- | Types for our intermediatary representation. 32 | -- Use the same as the parser generated types. 33 | -- type Bit = P.Bit 34 | -- type Gate = P.Gate 35 | 36 | -- | Representation of functions 37 | data Function = Func String Type Term 38 | 39 | instance Ord Function where 40 | compare (Func a _ _) (Func b _ _) = compare a b 41 | 42 | instance Eq Function where 43 | Func a _ _ == Func b _ _ = a == b 44 | 45 | type Program = [Function] 46 | 47 | fname :: P.FunVar -> String 48 | fname (P.FunVar v) = filter (\x -> x /= ' ' && x /= ':') v 49 | 50 | name :: P.Var -> String 51 | name (P.Var v) = v 52 | 53 | nameL :: P.LetVar -> String 54 | nameL (P.LVar v) = name v 55 | 56 | -- | A term in our intermediatary representation. 57 | data Term 58 | = Idx Integer -- bound 59 | | Fun String -- free 60 | | Bit AST.AST.Bit 61 | | Gate Gate 62 | | Tup Term Term 63 | | App Term Term 64 | | IfEl Term Term Term 65 | | Let Term Term 66 | | Abs Type Term 67 | | New 68 | | Meas 69 | | Unit 70 | deriving Eq 71 | 72 | data Gate 73 | = GH 74 | | GX 75 | | GY 76 | | GZ 77 | | GI 78 | | GS 79 | | GT 80 | | GCNOT 81 | | GTOF 82 | | GSWP 83 | | GFRDK 84 | | GQFT Int 85 | | GQFTI Int 86 | | GCR Double 87 | | GCRI Double 88 | | GCCR Double 89 | | GCCRI Double 90 | | GGate P.GateIdent 91 | deriving (Eq, Ord) 92 | 93 | instance Show Gate where 94 | show = printTree . reverseGate 95 | 96 | data Bit = BZero | BOne 97 | deriving (Eq, Ord, Show, Read) 98 | instance Show Function where 99 | show (Func n t e) = "\n" ++ n ++ " : " ++ show t ++ "\n" 100 | ++ n ++ " = " ++ show e ++ "\n" 101 | 102 | instance Show Term where 103 | show = printTree . reverseImTerm 0 104 | 105 | data Type 106 | = TypeBit 107 | | TypeQBit 108 | | TypeUnit 109 | | TypeDup Type 110 | | Type :>< Type 111 | | Type :=> Type 112 | deriving (Eq, Ord, Read) 113 | 114 | infixr 1 :=> 115 | infixr 2 :>< 116 | 117 | instance Show Type where 118 | show = printTree . reverseType 119 | 120 | -- | Converts from Parser type to our representation of type. 121 | convertType :: P.Type -> Type 122 | convertType P.TypeBit = TypeBit 123 | convertType P.TypeQbit = TypeQBit 124 | convertType P.TypeUnit = TypeUnit 125 | convertType (P.TypeDup type') = TypeDup (convertType type') 126 | convertType (P.TypeTens l r) = convertType l :>< convertType r 127 | convertType (P.TypeFunc l r) = convertType l :=> convertType r 128 | 129 | -- | Converts from our type to Parser type . 130 | reverseType :: Type -> P.Type 131 | reverseType TypeBit = P.TypeBit 132 | reverseType TypeQBit = P.TypeQbit 133 | reverseType TypeUnit = P.TypeUnit 134 | reverseType (TypeDup type') = P.TypeDup (reverseType type') 135 | reverseType (l :>< r) = P.TypeTens (reverseType l) (reverseType r) 136 | reverseType (l :=> r) = P.TypeFunc (reverseType l) (reverseType r) 137 | 138 | -- | Converts a Parser Term to our intermediatary Term. 139 | -- 140 | -- de Bruijn every bound variable (Let and function abstraction). 141 | -- Uses an environment to keep track of the Bruijn indicies. 142 | -- Converts names such as "new" to its own terms New. 143 | makeImTerm :: Env -> P.Term -> Term 144 | makeImTerm env (P.TLamb _ var type' term) = Abs (convertType type') $ makeImTerm env' term 145 | where env' = M.insert (fname var) 0 (M.map succ env) 146 | makeImTerm env (P.TApp l r) = App (makeImTerm env l) (makeImTerm env r) 147 | makeImTerm env (P.TVar (P.Var "new")) = New 148 | makeImTerm env (P.TVar (P.Var "meas")) = Meas 149 | makeImTerm env (P.TVar (P.Var "measure")) = Meas 150 | makeImTerm env (P.TDolr f x) = App (makeImTerm env f) (makeImTerm env x) 151 | makeImTerm env (P.TVar var) = case M.lookup (name var) env of 152 | Just idx -> Idx idx 153 | Nothing -> Fun (name var) 154 | makeImTerm env (P.TIfEl cond true false) = 155 | IfEl (makeImTerm env cond) (makeImTerm env true) (makeImTerm env false) 156 | makeImTerm env (P.TLet x [y] eq inn) = Let (makeImTerm env eq) (makeImTerm (letEnv y x env) inn) 157 | makeImTerm env (P.TLet x (y:ys) eq inn) = Let (makeImTerm env eq) (makeImTerm (letEnv y x env) (P.TLet y ys (toTerm y) inn)) 158 | makeImTerm env (P.TTup (P.Tuple t ts)) = foldr1 Tup $ map (makeImTerm env) (t:ts) 159 | 160 | makeImTerm _env (P.TBit (P.BBit 0)) = Bit BZero 161 | makeImTerm _env (P.TBit (P.BBit 1)) = Bit BOne 162 | makeImTerm _env (P.TGate (P.GIdent (P.GateIdent g))) 163 | | init g == "QFT" = Gate $ GQFT (nums g) 164 | | init g == "QFTI" = Gate $ GQFTI (nums g) 165 | | takeWhile isLetter g == "CR" = Gate $ GCR (nums g) 166 | | takeWhile isLetter g == "CRI" = Gate $ GCRI (nums g) 167 | | takeWhile isLetter g == "CCR" = Gate $ GCCR (nums g) 168 | | takeWhile isLetter g == "CCRI" = Gate $ GCCRI (nums g) 169 | where nums :: Read a => String -> a 170 | nums = read . dropWhile isLetter 171 | 172 | 173 | 174 | makeImTerm _env (P.TGate g) = Gate $ gateToASTGate g 175 | makeImTerm _env P.TStar = Unit 176 | 177 | letEnv :: P.LetVar -> P.LetVar -> Env -> Env 178 | letEnv x y env = M.insert (nameL y) 1 $ M.insert (nameL x) 0 (M.map (succ . succ) env) 179 | 180 | toTerm :: P.LetVar -> P.Term 181 | toTerm (P.LVar v) = P.TVar v 182 | 183 | -- | Convert a function to intermediate abstract syntax (lambdaized, with de Bruijn indices) 184 | makeImFunction :: P.FunDec -> Function 185 | makeImFunction (P.FDecl _ t function) = Func name (convertType t) term --(unfun n) (convertType t) (makeImTerm M.empty $ lambdaize fun) 186 | where 187 | (P.FDef (P.Var name) args body) = function 188 | term = makeImTerm M.empty $ lambdaize (debangFunc t) args body 189 | 190 | -- | Debangs outer level of a type. 191 | debangFunc :: P.Type -> P.Type 192 | debangFunc (P.TypeDup t@(P.TypeFunc n p)) = t 193 | debangFunc t = t 194 | 195 | -- | Lambdaizes and types the argument types based on the type signature. 196 | lambdaize :: P.Type -> [P.Arg] -> P.Term -> P.Term 197 | lambdaize _t [] body = body 198 | lambdaize (P.TypeFunc n p) (P.FArg (P.Var v) : vs) body = P.TLamb (P.Lambda "\\") (P.FunVar v) n (lambdaize p vs body) 199 | lambdaize (P.TypeDup (P.TypeFunc n p)) (P.FArg (P.Var v) : vs) body = P.TLamb (P.Lambda "\\") (P.FunVar v) n (lambdaize p vs body) 200 | 201 | -- | Translate abstract syntax from parser to intermediate abstract syntax 202 | toIm :: P.Program -> Program 203 | toIm (P.PDef fs) = map makeImFunction fs 204 | 205 | -- | Translate the intermediate abstract syntax to the abstract parser syntax. 206 | fromIm :: Program -> P.Program 207 | fromIm = P.PDef . map reverseImFunction 208 | 209 | -- | Convert a function from intermediate abstract syntax to the abstract parser syntax. 210 | reverseImFunction :: Function -> P.FunDec 211 | reverseImFunction (Func name type' term) = P.FDecl (P.FunVar name) (reverseType type')function 212 | where 213 | function = P.FDef (P.Var name) [] (reverseImTerm 0 term) 214 | 215 | -- | imTerm in reverse. From the intermediate term to the parser term. 216 | reverseImTerm :: Integer -> Term -> P.Term 217 | reverseImTerm env (Idx idx) = P.TVar $ P.Var $ 'x' : show (env - idx - 1) 218 | reverseImTerm env (Fun s) = P.TVar $ P.Var s 219 | reverseImTerm env (Bit BZero) = P.TBit $ P.BBit 0 220 | reverseImTerm env (Bit BOne) = P.TBit $ P.BBit 1 221 | 222 | reverseImTerm env (Gate g) = P.TGate $ reverseGate g 223 | reverseImTerm env (Tup l r) = P.TTup $ P.Tuple (reverseImTerm env l) [reverseImTerm env r] -- FIXME 224 | reverseImTerm env (App t1 t2) = P.TApp (reverseImTerm env t1) (reverseImTerm env t2) 225 | reverseImTerm env (IfEl c t e) = P.TIfEl (reverseImTerm env c) (reverseImTerm env t) (reverseImTerm env e) 226 | reverseImTerm env (Let eq inn) = P.TLet (P.LVar . P.Var $ 'x' : show env) 227 | [P.LVar . P.Var $ 'x' : show (env+1)] (reverseImTerm env eq) (reverseImTerm (env + 2) inn) 228 | reverseImTerm env (Abs type' term) = P.TLamb (P.Lambda "\\") (P.FunVar ('x' : show env)) (reverseType type') (reverseImTerm (env+1) term) 229 | reverseImTerm env New = P.TVar (P.Var "new") 230 | reverseImTerm env Meas = P.TVar (P.Var "meas") 231 | reverseImTerm env Unit = P.TStar 232 | 233 | reverseImGate :: p -> Term -> P.Term 234 | reverseImGate env (Gate GH) = P.TGate P.GH 235 | reverseImGate env (Gate GCNOT) = P.TGate P.GCNOT 236 | reverseImGate env (Gate GX) = P.TGate P.GX 237 | reverseImGate env (Gate GSWP) = P.TGate P.GSWP 238 | reverseImGate env (Gate (GCR n)) = P.TGate (P.GIdent (P.GateIdent $"GCR" ++ show n)) 239 | reverseImGate env (Gate (GCRI n)) =P.TGate (P.GIdent (P.GateIdent $ "GCRI" ++ show n)) 240 | reverseImGate env (Gate (GCCR n)) =P.TGate (P.GIdent (P.GateIdent $ "GCCR" ++ show n)) 241 | reverseImGate env (Gate (GCCRI n)) =P.TGate (P.GIdent (P.GateIdent $ "GCCRI" ++ show n)) 242 | reverseImGate env (Gate (GQFT n)) =P.TGate (P.GIdent (P.GateIdent $ "GQFT" ++ show n)) 243 | reverseImGate env (Gate (GQFTI n)) =P.TGate (P.GIdent (P.GateIdent $ "GQFTI" ++ show n)) 244 | run :: String -> Program 245 | run s = case pProgram (myLexer s) of 246 | Left s -> errorWithoutStackTrace s 247 | Right p -> toIm p 248 | 249 | test :: String -> String 250 | test = printTree . fromIm . run 251 | 252 | testFile :: FilePath -> IO String 253 | testFile path = test <$> readFile path 254 | 255 | propTestFile :: FilePath -> IO Bool 256 | propTestFile path = do 257 | once <- testFile path 258 | let twice = test once 259 | return (once == twice) 260 | 261 | runFile :: FilePath -> IO Program 262 | runFile path = run <$> readFile path 263 | 264 | gateToASTGate :: P.Gate -> Gate 265 | gateToASTGate g = case g of 266 | P.GH -> GH 267 | P.GX -> GX 268 | P.GY -> GY 269 | P.GZ -> GZ 270 | P.GI -> GI 271 | P.GS -> GS 272 | P.GT -> AST.AST.GT 273 | P.GCNOT -> GCNOT 274 | P.GTOF -> GTOF 275 | P.GSWP -> GSWP 276 | P.GFRDK -> GFRDK 277 | 278 | reverseGate :: Gate -> P.Gate 279 | reverseGate g = case g of 280 | GH -> P.GH 281 | GX -> P.GX 282 | GY -> P.GY 283 | GZ -> P.GZ 284 | GI -> P.GI 285 | GS -> P.GS 286 | GCNOT -> P.GCNOT 287 | GTOF -> P.GTOF 288 | GSWP -> P.GSWP 289 | GFRDK -> P.GFRDK 290 | AST.AST.GT -> P.GT 291 | GQFT i -> P.GIdent $ P.GateIdent $ "QFT" ++ show i 292 | GQFTI i -> P.GIdent $ P.GateIdent $ "QFTI" ++ show i 293 | GCR i -> P.GIdent $ P.GateIdent $ "CR" ++ show (round i) 294 | GCRI i -> P.GIdent $ P.GateIdent $ "CRI" ++ show (round i) 295 | GCCR i -> P.GIdent $ P.GateIdent $ "CCR" ++ show (round i) 296 | GCCRI i -> P.GIdent $ P.GateIdent $ "CCRI" ++ show (round i) -------------------------------------------------------------------------------- /src/Type/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Type.TypeChecker where 5 | import AST.AST as A 6 | import Control.Monad.Except hiding (throwError) 7 | import qualified Control.Monad.Except as EX 8 | import Control.Monad.Reader 9 | import Control.Monad.State 10 | import qualified Data.Map as M 11 | import qualified Data.Set as S 12 | import Data.String 13 | import Data.Maybe 14 | 15 | runCheck :: Check a -> Either TypeError a 16 | runCheck c = runCheckWith c M.empty emptyErrorEnv 17 | 18 | runCheckWith :: Check a -> TopEnv -> ErrorEnv -> Either TypeError a 19 | runCheckWith c t = evalState (runReaderT (runExceptT c) t) 20 | 21 | -- | Typecheck a program. 22 | -- Returns TypeError on failure an unit on success. 23 | typecheck :: Program -> Either TypeError () 24 | typecheck program = evalState (runReaderT (runExceptT (typecheckP program)) top) emptyErrorEnv 25 | where top = buildTopEnv program 26 | 27 | -- | Parse a typecheck a program encoded as a string. 28 | tcStr :: String -> Either TypeError () 29 | tcStr = typecheck . run 30 | 31 | inferExp :: String -> Either TypeError Type 32 | inferExp = runCheck . infer . parseExp 33 | 34 | parseExp :: String -> Term 35 | parseExp s = p 36 | where [Func _ _ p] = run $ "f : T f = " ++ s 37 | 38 | -- | All type errors that can occur. 39 | data ErrorTypes 40 | = NotFunction Type -- ^ A type was expected to be a function but was not. 41 | | Mismatch Type Type -- ^ Expected a type but found another type. 42 | | NotProduct Type -- ^ A type was expected to be a product but was not. 43 | | NotLinearTop String -- ^ A function that is linear used many times. 44 | | NotLinearTerm Term Type -- ^ A term that breaks a linearity constraint 45 | | NoCommonSuper Type Type -- ^ No common supertype was found 46 | | NotInScope String -- ^ A function was not in scope. 47 | deriving Eq 48 | 49 | data TypeError = TError String ErrorTypes 50 | deriving Eq 51 | 52 | instance Show TypeError where 53 | show (TError where' why) = 54 | "type error in function " ++ where' ++ ":\n" ++ show why 55 | 56 | throwError :: ErrorTypes -> Check a 57 | throwError err = do 58 | name <- gets currentFun 59 | EX.throwError (TError name err) 60 | 61 | instance Show ErrorTypes where 62 | show (NotFunction t) = 63 | "Type '" ++ show t ++ "' is not a function type" 64 | 65 | show (Mismatch e a) = 66 | "Couldn't match expected type '" ++ show e ++ 67 | "' with actual type '" ++ show a ++ "'" 68 | 69 | show (NotProduct t) = 70 | "Not a factorizable type '" ++ show t ++ "'" 71 | 72 | show (NotLinearTop f) = 73 | "Linear function '" ++ f ++ "' is used more than once" 74 | 75 | show (NotLinearTerm e t) = 76 | "Expression breaks linearity constraint: " ++ show (Abs t e) 77 | 78 | show (NoCommonSuper a b) = 79 | "Could not find common type for type '" ++ show a ++ "' and type '" ++ show b ++ "'" 80 | 81 | show (NotInScope v) = 82 | "Variable not in scope: " ++ v 83 | 84 | instance IsString Type where 85 | fromString t = t' 86 | where [Func _ t' _] = run $ "f : " ++ t ++ " f = *" 87 | 88 | -- | Typecheck the program inside Check monad. 89 | typecheckP :: Program -> Check () 90 | typecheckP = mapM_ typecheckF 91 | 92 | -- Typechecks the function inside the check monad. 93 | typecheckF :: Function -> Check () 94 | typecheckF (Func name type' term) = do 95 | modify $ \s -> s{currentFun=name} 96 | t <- infer term 97 | if t <: type' 98 | then return () 99 | else throwError (Mismatch type' t) 100 | 101 | data ErrorEnv 102 | = ErrorEnv { linenv :: LinEnv 103 | , currentFun :: String 104 | } 105 | 106 | type LinEnv = S.Set String 107 | type TopEnv = M.Map String Type 108 | 109 | emptyErrorEnv :: ErrorEnv 110 | emptyErrorEnv = ErrorEnv S.empty "MEGA URK" 111 | 112 | -- | Builds map between top level names and types. 113 | buildTopEnv :: Program -> TopEnv 114 | buildTopEnv program = M.fromList (map addFunc program) 115 | where 116 | addFunc :: Function -> (String, Type) 117 | addFunc (Func name t _) = (name, t) 118 | 119 | -- | Ability to throw type errors when type checking. 120 | type Check = ExceptT TypeError (ReaderT TopEnv (State ErrorEnv)) 121 | 122 | -- | Whether a type is a subtype of another type. 123 | (<:) :: Type -> Type -> Bool 124 | TypeDup a <: TypeDup b = TypeDup a <: b -- (!) 125 | TypeDup (a1 :>< a2) <: (b1 :>< b2) = TypeDup a1 <: b1 && TypeDup a2 <: b2 -- (!><) 126 | TypeDup a <: b = a <: b -- (D) 127 | (a1 :>< a2) <: (b1 :>< b2) = a1 <: b1 && a2 <: b2 -- (><) 128 | (a' :=> b) <: (a :=> b') = a <: a' && b <: b' -- (-o) 129 | a <: b = a == b -- (ax) 130 | 131 | parallelCheck :: Check a -> Check b -> Check (a,b) 132 | parallelCheck a b = do 133 | env <- get 134 | a' <- a 135 | lina <- gets linenv 136 | put env 137 | b' <- b 138 | linb <- gets linenv 139 | modify $ \s -> s{linenv=S.union lina linb} 140 | return (a',b') 141 | 142 | -- | Count how many times the variable bound to the head is used. 143 | headCount :: Term -> Integer 144 | headCount = headCount' 0 145 | where 146 | headCount' :: Integer -> Term -> Integer 147 | headCount' absl term = case term of 148 | Idx i -> if absl == i then 1 else 0 149 | Abs _ e -> headCount' (absl+1) e 150 | App f arg -> headCount' absl f + headCount' absl arg 151 | IfEl c t f -> headCount' absl c + max (headCount' absl t) (headCount' absl f) 152 | Tup l r -> headCount' absl l + headCount' absl r 153 | Let eq inn -> headCount' absl eq + headCount' (absl+2) inn 154 | _ -> 0 155 | 156 | checkLinear :: Term -> Type -> Check () 157 | checkLinear e = \case 158 | TypeDup t -> return () 159 | t -> if headCount e <= 1 160 | then return () 161 | else throwError $ NotLinearTerm e t 162 | 163 | infer :: Term -> Check Type 164 | infer = inferTerm [] 165 | 166 | -- | Infer the type of a term. 167 | inferTerm :: [Type] -> Term -> Check Type 168 | inferTerm _ Unit = return $ TypeDup TypeUnit 169 | inferTerm _ (Bit _) = return $ TypeDup TypeBit 170 | inferTerm _ New = return $ TypeDup (TypeBit :=> TypeQBit) 171 | inferTerm _ Meas = return $ TypeDup (TypeQBit :=> TypeDup TypeBit) 172 | inferTerm _ (Gate g) = return $ inferGate g 173 | inferTerm ctx (Abs t e) = do 174 | top <- ask 175 | checkLinear e t 176 | et <- inferTerm (t:ctx) e 177 | let boundLin = any (isLinear . (ctx !!) . fromIntegral) (freeVars (Abs t e)) 178 | let freeLin = any isLinear $ mapMaybe (`M.lookup` top) (names e) 179 | if boundLin || freeLin 180 | then return (t :=> et) 181 | else return $ TypeDup (t :=> et) 182 | inferTerm ctx (Let eq inn) = do 183 | teq <- inferTerm ctx eq 184 | let nBangs = numBangs teq 185 | case debangg teq of 186 | (a1 :>< a2) -> do 187 | let a1t = addBangs nBangs a1 188 | let a2t = addBangs nBangs a2 189 | checkLinear inn a2t 190 | checkLinear (Abs a2t inn) a1t 191 | inferTerm (a2t : a1t : ctx) inn 192 | _ -> throwError $ NotProduct teq 193 | inferTerm ctx (App f arg) = do 194 | tf <- inferTerm ctx f 195 | argT <- inferTerm ctx arg 196 | case debangg tf of 197 | (fArg :=> fRet) | argT <: fArg -> return fRet 198 | | otherwise -> throwError $ Mismatch fArg argT 199 | _ -> throwError $ NotFunction tf 200 | inferTerm ctx (Tup l r) = do 201 | lt <- inferTerm ctx l 202 | rt <- inferTerm ctx r 203 | return $ shiftBang (lt :>< rt) 204 | inferTerm ctx (Idx i) = return $ ctx !! fromIntegral i 205 | inferTerm _ (Fun fun) = do 206 | top <- ask 207 | lin <- gets linenv 208 | case M.lookup fun top of 209 | Nothing -> throwError $ NotInScope fun 210 | Just t | isLinear t -> if S.member fun lin 211 | then throwError $ NotLinearTop fun 212 | else modify (\s -> s {linenv = S.insert fun lin}) >> return t 213 | | otherwise -> return t 214 | inferTerm ctx (IfEl c t f) = do 215 | tc <- inferTerm ctx c 216 | (tt, tf) <- parallelCheck (inferTerm ctx t) (inferTerm ctx f) 217 | if tc <: TypeBit 218 | then supremum tt tf 219 | else throwError $ Mismatch TypeBit tc 220 | 221 | -- | Find the largest commont subtype (greatest lower bound). 222 | -- Throws error if no common subtype exists. 223 | infimum :: Type -> Type -> Check Type 224 | infimum a b | a == b = return a 225 | infimum (TypeDup (a :>< b)) (c :>< d) = (:><) <$> infimum (TypeDup a) c <*> infimum (TypeDup b) d 226 | infimum (a :>< b) (TypeDup (c :>< d)) = (:><) <$> infimum a (TypeDup c) <*> infimum b (TypeDup d) 227 | infimum (TypeDup a) (TypeDup b) = TypeDup <$> infimum a b 228 | infimum (TypeDup a) b = TypeDup <$> infimum a b 229 | infimum a (TypeDup b) = TypeDup <$> infimum a b 230 | infimum (a :>< b) (c :>< d) = (:><) <$> infimum a c <*> infimum b d 231 | infimum (a :=> b) (c :=> d) = (:=>) <$> supremum a c <*> infimum b d -- NOTE: contravariance of negative type 232 | infimum a b = throwError (NoCommonSuper a b) 233 | 234 | -- | Finds the smallest common supertype (least upper bound). 235 | -- Throws error if no common supertype exists. 236 | supremum :: Type -> Type -> Check Type 237 | supremum a b | a == b = return a 238 | supremum (TypeDup (a :>< b)) (c :>< d) = (:><) <$> supremum (TypeDup a) c <*> supremum (TypeDup b) d 239 | supremum (a :>< b) (TypeDup (c :>< d)) = (:><) <$> supremum a (TypeDup c) <*> supremum b (TypeDup d) 240 | supremum (TypeDup a) (TypeDup b) = TypeDup <$> supremum a b 241 | supremum (TypeDup a) b = supremum a b 242 | supremum a (TypeDup b) = supremum a b 243 | supremum (a :>< b) (c :>< d) = (:><) <$> supremum a c <*> supremum b d 244 | supremum (a :=> b) (c :=> d) = (:=>) <$> infimum a c <*> supremum b d -- NOTE: contravariance of negative type 245 | supremum a b = throwError (NoCommonSuper a b) 246 | 247 | -- | Unwraps as many ! as possible from a type. 248 | debangg :: Type -> Type 249 | debangg (TypeDup a) = debangg a 250 | debangg a = a 251 | 252 | -- | Moves as many common bangs as possible from inside a tuple to the outside. 253 | shiftBang :: Type -> Type 254 | shiftBang (TypeDup a :>< TypeDup b) = TypeDup (shiftBang (a :>< b)) 255 | shiftBang a = a 256 | 257 | -- | Return how many ! a type is wrapped in. 258 | numBangs :: Type -> Integer 259 | numBangs (TypeDup a) = 1 + numBangs a 260 | numBangs a = 0 261 | 262 | -- | Wrap a type in some number of !. 263 | addBangs :: Integer -> Type -> Type 264 | addBangs 0 a = a 265 | addBangs n a = addBangs (n-1) (TypeDup a) 266 | 267 | -- | Whether a type is linear and not wrapped in !. 268 | isLinear :: Type -> Bool 269 | isLinear (TypeDup _) = False 270 | isLinear _ = True 271 | 272 | -- | Finds all free de bruijn variables in a term. 273 | freeVars :: Term -> [Integer] -- todo: make sure it is not off by one and the result integers makes sense according to the callee. 274 | freeVars = freeVars' 0 275 | where 276 | freeVars' :: Integer -> Term -> [Integer] 277 | freeVars' n (Tup l r) = freeVars' n l ++ freeVars' n r 278 | freeVars' n (App f a) = freeVars' n f ++ freeVars' n a 279 | freeVars' n (Let eq inn) = freeVars' n eq ++ freeVars' (n+2) inn 280 | freeVars' n (Abs _ e) = freeVars' (n+1) e 281 | freeVars' n (Idx i) = [i - n | i >= n] 282 | freeVars' _ _ = [] 283 | 284 | -- | Finds all functions used in a term. 285 | names :: Term -> [String] 286 | names (Tup l r) = names l ++ names r 287 | names (App f a) = names f ++ names a 288 | names (Let eq inn) = names eq ++ names inn 289 | names (Abs _ e) = names e 290 | names (Fun f) = [f] 291 | names _ = [] 292 | 293 | -- | Infer type of a gate. 294 | inferGate :: A.Gate -> Type 295 | inferGate g = TypeDup (arg :=> arg) 296 | where 297 | arg = foldr (:><) TypeQBit (replicate (n-1) TypeQBit) 298 | n = case g of 299 | GFRDK -> 3 300 | GTOF -> 3 301 | GSWP -> 2 302 | GCNOT -> 2 303 | GQFT n -> n 304 | GQFTI n -> n 305 | GCR _ -> 2 306 | GCRI _ -> 2 307 | GCCR _ -> 3 308 | GCCRI _ -> 3 309 | _ -> 1 310 | --------------------------------------------------------------------------------