diff --git a/ArrowVHDL.cabal b/ArrowVHDL.cabal new file mode 100644 --- /dev/null +++ b/ArrowVHDL.cabal @@ -0,0 +1,82 @@ +name: ArrowVHDL +version: 1.0 +synopsis: A library to generate Netlist code from Arrow descriptions. +description: This software is intended to help a developer designing electronic + circuits by describing them with arrows. The arrow notation represents + the according. From the netlist the developer can generate various + other formats by "compiling" the arrow into them. With this software + three basic compilers are shipped. One generates a simple textual + representation that helps debugging the actual circuit. Another + generates VHDL representations of the circuit. The third one generates + DOT syntax for visualization of circuits. +homepage: https://github.com/frosch03/arrowVHDL +license: PublicDomain +license-file: LICENSE +author: Matthias Brettschneider +maintainer: brettschneider@frosch03.de +category: Testing +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + -- Modules exported by the library. + exposed-modules: System.ArrowVHDL.Beispiel, + System.ArrowVHDL.Circuit, + System.ArrowVHDL.CRC, + System.ArrowVHDL.ALU, + System.ArrowVHDL.TEA, + System.ArrowVHDL.Test + + other-modules: System.ArrowVHDL.Circuit.Grid, + System.ArrowVHDL.Circuit.EdgeTransit, + System.ArrowVHDL.Circuit.IEEE_STD_LOGIC_1164, + System.ArrowVHDL.Circuit.Defaults, + System.ArrowVHDL.Circuit.Tools, + System.ArrowVHDL.Circuit.Show, + System.ArrowVHDL.Circuit.Workers, + System.ArrowVHDL.Circuit.Tests, + System.ArrowVHDL.Circuit.Graphs, + System.ArrowVHDL.Circuit.Descriptor, + System.ArrowVHDL.Circuit.Splice, + System.ArrowVHDL.Circuit.ShowType, + System.ArrowVHDL.Circuit.Sensors, + System.ArrowVHDL.Circuit.Auxillary, + System.ArrowVHDL.Circuit.PinTransit, + System.ArrowVHDL.Circuit.Arrow, + System.ArrowVHDL.Circuit.Stream, + System.ArrowVHDL.Circuit.Grid.Datatype, + System.ArrowVHDL.Circuit.Grid.Instance, + System.ArrowVHDL.Circuit.Stream.Datatype, + System.ArrowVHDL.Circuit.Stream.Instance, + System.ArrowVHDL.Circuit.Arrow.Helpers, + System.ArrowVHDL.Circuit.Arrow.Instance, + System.ArrowVHDL.Circuit.Arrow.Class, + System.ArrowVHDL.Circuit.Show.Tools, + System.ArrowVHDL.Circuit.Show.Simple, + System.ArrowVHDL.Circuit.Show.DOT, + System.ArrowVHDL.Circuit.Show.VHDL, + System.ArrowVHDL.Circuit.ShowType.Instance, + System.ArrowVHDL.Circuit.ShowType.Class + + other-extensions: Arrows + , NoMonomorphismRestriction + , RebindableSyntax + , RankNTypes + , OverlappingInstances + , UndecidableInstances + , IncoherentInstances + , MultiParamTypeClasses + , FlexibleInstances + + build-depends: base >=4.6 && <4.7 + , process >=1.1 && <1.2 + + -- Directories containing source files. + hs-source-dirs: src + + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/frosch03/arrowVHDL.git diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +just some minor vhdl-hacking with the help of haskell ;) + +questions: frosch03@gmail.com diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/System/ArrowVHDL/ALU.hs b/src/System/ArrowVHDL/ALU.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/ALU.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, RebindableSyntax #-} +module System.ArrowVHDL.ALU +where + +import Prelude hiding (id, (.)) + +import Control.Category -- here we get >>> ... + +import System.ArrowVHDL.Circuit +import System.ArrowVHDL.Circuit.Arrow -- here we get first and second +import System.ArrowVHDL.Circuit.Defaults + +type Input = (Bool, Bool) +type Output = Bool +type Cin = Bool +type Cout = Bool +type Opt1Bit = Bool +type Opt2Bit = (Opt1Bit, Opt1Bit) +type Opt3Bit = (Opt1Bit, Opt2Bit) +type Opt4Bit = (Opt1Bit, Opt3Bit) + +type In2Bit = (Input, (Input)) +type Out2Bit = (Output, (Output)) + +type In4Bit = (Input, (Input, (Input, (Input)))) +type Out4Bit = (Output, (Output, (Output, (Output)))) + +type In8Bit = (Input, (Input, (Input, (Input, (Input, (Input, (Input, (Input)))))))) +type Out8Bit = (Output, (Output, (Output, (Output, (Output, (Output, (Output, (Output)))))))) + + +-- aFst +-- aSnd +-- aXor +-- aShiftL +-- aShiftR +-- aAdd + + +aDdistr_new :: (Arrow a) => Grid a ((b, c), (b, e)) (b, (c, e)) +aDdistr_new + = proc ((x1, y), (x2, z)) -> do + returnA -< (x1, (y, z)) + + +-- |With the 'noC' operator, one can shortwire the CarryIn bit direct to the CarryOut bit +noC :: (Arrow a) => (Grid a Input Output) -> Grid a (Cin, Input) (Output, Cout) +noC arrow + = second arrow + >>> aFlip + + +-- |'aFullAdd' is the full adder implementation +aFullAdd :: (Arrow a) => Grid a (Cin, Input) (Output, Cout) +aFullAdd + = second (aXor &&& aAnd) + >>> a_aBC2ABc + >>> first (aXor &&& aAnd) + >>> a_ABc2aBC + >>> second (aOr) + +-- Multiplexer -- + +-- | With 'aMux' a 1 Bit multiplexer is defined +aMux :: (Arrow a) => Grid a (Opt1Bit, (Output, Output)) Output +aMux + = aDistr + >>> first (first aNot) + >>> aAnd *** aAnd + >>> aOr + +aMux2Bit :: (Arrow a) -- 00 01 10 11 + => Grid a (Opt2Bit, ((Output, Output), (Output, Output))) Output +aMux2Bit + = a_ABc2aBC + >>> second aDistr + >>> second (aMux *** aMux) + >>> aMux + +aMux3Bit :: (Arrow a) -- 000 001 010 011 100 101 110 111 + => Grid a (Opt3Bit, (((Output, Output), (Output, Output)), ((Output, Output), (Output, Output)))) Output +aMux3Bit + = a_ABc2aBC + >>> second aDistr + >>> second (aMux2Bit *** aMux2Bit) + >>> aMux + +aMux4Bit :: (Arrow a) + => Grid a (Opt4Bit, ( (((Output, Output), (Output, Output)), ((Output, Output), (Output, Output))) + , (((Output, Output), (Output, Output)), ((Output, Output), (Output, Output))))) Output +aMux4Bit + = a_ABc2aBC + >>> second aDistr + >>> second (aMux3Bit *** aMux3Bit) + >>> aMux + +-- |'anXum' is the Multiplexer where the last input-pin is the s-line +-- |it is generated out of one of the mux'es +anXum mux = aFlip + >>> mux + +aXum = anXum aMux +a2Xum = anXum aMux2Bit +a3Xum = anXum aMux3Bit +a4Xum = anXum aMux4Bit + +--_____________-- + +--eval :: (Arrow a) => Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) -> Grid a (Cin, (Opt1Bit, (Input, rest))) (Output, (Cout, (Opt1Bit, rest))) +-- |The 'eval' function takes a single bit ALU and evaluates the first bit of a multiBit input +-- so with 'eval' one can define the steps of n-Bit ALU +eval aALU + = second aDistr + >>> a_aBC2ABc + >>> first aALU + >>> a_ABc2aBC + +-- n-Bit ALU's -- + +--a1BitALU :: (Arrow a) => Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) +-- -> Grid a (Cin, (Opt1Bit, (Input))) (Output, (Cout)) +mk1BitALU = id + + +--a2BitALU :: (Arrow a) => Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) +-- -> Grid a (Cin, (Opt1Bit, (Input, (Input)))) +-- (Output, (Output, (Cout))) +mk2BitALU aALU + = eval aALU >>> next aALU + where next = second + + +--a4BitALU :: (Arrow a) => Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) +-- -> Grid a (Cin, (Opt1Bit, (Input, (Input, (Input, (Input)))))) +-- (Output, (Output, (Output, (Output, (Cout))))) +mk4BitALU aALU + = eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next aALU)) + where next = second + + +--a8BitALU :: Arrow a => Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) +-- -> Grid a (Cin, (Opt1Bit, (Input, (Input, (Input, (Input, (Input, (Input, (Input, Input))))))))) +-- (Output, (Output, (Output, (Output, (Output, (Output, (Output, (Output, Cout)))))))) +mk8BitALU aALU + = eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next + ( eval aALU >>> next aALU)))))) + where next = second + + +-- n-Bit ALU's -- +--_____________-- + +-- n-Bit Operators -- + +aOpt1Bit :: (Arrow a) + => Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, (Opt1Bit, Input)) (Output, Cout) +aOpt1Bit aOp0 aOp1 + = a_aBC2ABc + >>> first aFlip + >>> a_ABc2aBC + >>> second + ( aOp0 &&& aOp1 + >>> aDdistr + ) + >>> aDistr + >>> aMux *** aMux + + +aOpt2Bit :: (Arrow a) + => Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, (Opt2Bit, Input)) (Output, Cout) +aOpt2Bit aOp00 aOp01 aOp10 aOp11 + = a_aBC2ABc + >>> first aFlip + >>> a_ABc2aBC + >>> second + ( (aOp00 &&& aOp01) &&& (aOp10 &&& aOp11) + >>> aDdistr *** aDdistr + >>> aDdistr + ) + >>> aDistr + >>> aMux2Bit *** aMux2Bit + + +aOpt3Bit :: (Arrow a) + => Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, (Opt3Bit, Input)) (Output, Cout) +aOpt3Bit aOp000 aOp001 aOp010 aOp011 aOp100 aOp101 aOp110 aOp111 + = a_aBC2ABc + >>> first aFlip + >>> a_ABc2aBC + >>> second + ( ((aOp000 &&& aOp001) &&& (aOp010 &&& aOp011)) &&& ((aOp100 &&& aOp101) &&& (aOp110 &&& aOp111)) + >>> (aDdistr *** aDdistr) *** (aDdistr *** aDdistr) + >>> aDdistr *** aDdistr + >>> aDdistr + ) + >>> aDistr + >>> aMux3Bit *** aMux3Bit + + + +aOpt4Bit :: (Arrow a) + => Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, Input) (Cout, Output) + -> Grid a (Cin, (Opt4Bit, Input)) (Output, Cout) +aOpt4Bit aOp0000 aOp0001 aOp0010 aOp0011 aOp0100 aOp0101 aOp0110 aOp0111 aOp1000 aOp1001 aOp1010 aOp1011 aOp1100 aOp1101 aOp1110 aOp1111 + = a_aBC2ABc + >>> first aFlip + >>> a_ABc2aBC + >>> second + ( (((aOp0000 &&& aOp0001) &&& (aOp0010 &&& aOp0011)) &&& ((aOp0100 &&& aOp0101) &&& (aOp0110 &&& aOp0111))) + &&& (((aOp1000 &&& aOp1001) &&& (aOp1010 &&& aOp1011)) &&& ((aOp1100 &&& aOp1101) &&& (aOp1110 &&& aOp1111))) + >>> ((aDdistr *** aDdistr) *** (aDdistr *** aDdistr)) *** ((aDdistr *** aDdistr) *** (aDdistr *** aDdistr)) + >>> (aDdistr *** aDdistr) *** (aDdistr *** aDdistr) + >>> aDdistr *** aDdistr + >>> aDdistr + ) + >>> aDistr + >>> aMux4Bit *** aMux4Bit + + +-- n-Bit Operators -- +--_________________-- + +aFAD_XOR_AND_OR = aOpt2Bit aFullAdd (noC aXor) (noC aAnd) (noC aOr) + +-- Auxillary -- + +t8b :: Int -> (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool)))))))) +t8b x + = (bit7, (bit6, (bit5, (bit4, (bit3, (bit2, (bit1, (bit0)))))))) + where (bit7: bit6: bit5: bit4: bit3: bit2: bit1: bit0: []) = i2t8b [] x + +i2t8b :: [Bool] -> Int -> [Bool] +i2t8b list x + | x == 0 + = list ++ (replicate (8 - (length list)) False) + + | x == 1 + = (list ++ [True]) ++ (replicate (8 - (length list) - 1) False) + + | x `mod` 2 == 0 + = i2t8b (list ++ [False]) (x `div` 2) + + | x `mod` 2 == 1 + = i2t8b (list ++ [True]) ( (x-1) `div` 2) + +inp8b :: Int -> Int -> In8Bit +inp8b x1 x2 + = ((bit07, bit17), ((bit06, bit16), ((bit05, bit15), ((bit04, bit14), ((bit03, bit13), ((bit02, bit12), ((bit01, bit11), ((bit00, bit10))))))))) + where (bit07: bit06: bit05: bit04: bit03: bit02: bit01: bit00: []) = i2t8b [] x1 + (bit17: bit16: bit15: bit14: bit13: bit12: bit11: bit10: []) = i2t8b [] x2 + +-- Auxillary -- +--___________-- diff --git a/src/System/ArrowVHDL/Beispiel.hs b/src/System/ArrowVHDL/Beispiel.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Beispiel.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, RebindableSyntax #-} +module System.ArrowVHDL.Beispiel where + +import Control.Category +import Prelude hiding (id, (.)) + +import System.ArrowVHDL.Circuit.Arrow +import System.ArrowVHDL.Circuit.Auxillary +import System.ArrowVHDL.Circuit.Descriptor + +-- Dissertation TODO +import System.ArrowVHDL.TEA +import System.ArrowVHDL.Circuit.Workers + +import System.ArrowVHDL.Circuit +import System.ArrowVHDL.Circuit.Defaults + ( aId + , aConst + , aDup + , aFlip + , aAdd + , aXor + , aShiftL, aShiftL4 + , aShiftR, aShiftR5 + , aXorMagic + , aFst, aSnd + ) + +aAdd1 :: (Arrow a) => a Int Int +aAdd1 = arr (\x -> x +1) + +aSub1 :: (Arrow a) => a Int Int +aSub1 = arr (\x -> x -1) + +aSub2 = aSub1 >>> aSub1 + + + +-- Beispiel 0 +------------- +aTest0 + = aDup + >>> aAdd + +netlist_Test0 :: CircuitDescriptor +netlist_Test0 + = synthesize aTest0 + + +-- Beispiel 1 +------------- +aTest1 + = proc (x) -> do + tmp <- aAdd -< (x, x) + returnA -< tmp + +_netlist_Test1 + = synthesize aTest1 + + +-- Beispiel 2 +------------- +aTest2 + = proc (x1, x2) -> do + tmp1 <- aDup -< x1 + tmp2 <- aDup -< x2 + tmp3 <- aAdd -< tmp1 + tmp4 <- aAdd -< tmp2 + tmp5 <- aAdd -< (tmp3, tmp4) + returnA -< tmp5 + +_netlist_Test2 + = synthesize aTest2 + + +-- Beispiel 3 +------------- +aTest2' + = ((first aDup >>> arr (\ (tmp1, x2) -> (x2, tmp1))) >>> + (first aDup >>> arr (\ (tmp2, tmp1) -> (tmp1, tmp2))) >>> + (first aAdd >>> arr (\ (tmp3, tmp2) -> (tmp2, tmp3))) >>> + (first aAdd >>> arr (\ (tmp4, tmp3) -> (tmp3, tmp4))) >>> aAdd) + +netlist_Test2' + = synthesize aTest2' + + +-- Beispiel 4 +------------- +aShiftL4_XorKey + = first ( aDup + >>> second (aConst 4) + >>> aShiftL + ) + >>> aXor + +-- netlist_ShiftL4_XorKey +-- = synthesize aShiftL4_XorKey + + +-- Beispiel 5 +------------- +-- delta = 2654435769 +-- aXorDelta +-- = second (aConst delta) +-- >>> aXor + +-- netlist_XorDelta +-- = synthesize aXorDelta + + +-- Beispiel 6 +------------- +aShiftR5_XorKey + = first ( aDup + >>> second (aConst 5) + >>> aShiftR + ) + >>> aXor + +-- netlist_ShiftR5_XorKey +-- = synthesize aShiftR5_XorKey + + +counter :: (ArrowCircuit a) => a Int Int +counter = proc reset -> do + rec output <- (arr (+1)) -< reset + next <- delay 0 -< output + returnA -< output + + +aLoopBsp :: (ArrowLoop a) => Grid a Int Int +aLoopBsp + = loop (aAdd >>> (aId &&& (aConst 4))) + diff --git a/src/System/ArrowVHDL/CRC.hs b/src/System/ArrowVHDL/CRC.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/CRC.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE Arrows, + NoMonomorphismRestriction, + RebindableSyntax #-} +module System.ArrowVHDL.CRC +where + +import Prelude + +import Control.Category ((>>>)) + +import System.ArrowVHDL.Circuit +import System.ArrowVHDL.Circuit.Arrow +import System.ArrowVHDL.Circuit.Auxillary +import System.ArrowVHDL.Circuit.Defaults + +import Data.Bits + +infixr 0 >:> + +(>:>) aA aB = aA >>> (second aB) + +mvRight :: (Arrow a) => Grid a (my, (b, rst)) (b, (my, rst)) +mvRight + = aDistr + >>> first aSnd + + + +-- crc_polynom_ccitt :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, b)))) (b, (b, (b, b))) +crc_polynom_ccitt :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, Bool)))) (Bool, (Bool, (Bool, Bool))) +crc_polynom_ccitt + = mvRight >:> mvRight >:> + ( aDistr + >>> (aXor *** aXor) + ) + +-- crc_polynom_ccitt +-- = proc (x4, (x3, (x2, (x1, x0)))) -> do +-- o1 <- aXor -< (x4, x0) +-- o2 <- aXor -< (x4, x1) +-- o3 <- aId -< (x2) +-- o4 <- aId -< (x3) +-- returnA -< (o4, (o3, (o2, o1))) + +-- crc_polynom_usb :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, (b, b))))) (b, (b, (b, (b, b)))) +crc_polynom_usb :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))) (Bool, (Bool, (Bool, (Bool, Bool)))) +crc_polynom_usb + = mvRight >:> mvRight >:> + ( aDistr + >>> aXor *** (mvRight >:> aXor) + ) + +-- crc_polynom_usb +-- = proc (x5, (x4, (x3, (x2, (x1, x0))))) -> do +-- o1 <- aXor -< (x5, x0) +-- o2 <- aId -< (x1) +-- o3 <- aXor -< (x5, x2) +-- o4 <- aId -< (x3) +-- o5 <- aId -< (x4) +-- returnA -< (o5, (o4, (o3, (o2, o1)))) + +-- crc_polynom_sdmmc :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, (b, (b, (b, b))))))) (b, (b, (b, (b, (b, (b, b)))))) +crc_polynom_sdmmc :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool)))))) +crc_polynom_sdmmc + = mvRight >:> mvRight >:> mvRight >:> + ( aDistr + >>> aXor *** (mvRight >:> mvRight >:> aXor) + ) + +-- crc_polynom_sdmmc +-- = proc (x7, (x6, (x5, (x4, (x3, (x2, (x1, x0))))))) -> do +-- o1 <- aXor -< (x7, x0) +-- o2 <- aId -< (x1) +-- o3 <- aId -< (x2) +-- o4 <- aXor -< (x7, x3) +-- o5 <- aId -< (x4) +-- o6 <- aId -< (x5) +-- o7 <- aId -< (x6) +-- returnA -< (o7, (o6, (o5, (o4, (o3, (o2, o1)))) + + + +-- 3 2 1 0 2 1 0 +-- inner_crc_3ord :: (Arrow a, Bits b) => Grid a (b, (b, (b, b))) (b, (b, b)) +inner_crc_3ord + = aDistr + >>> aSnd *** aDistr + >>> second (aXor *** aXor) + + +toInner3 + = mvRight + >:> mvRight + >:> aFlip + +toInner4 + = mvRight + >:> mvRight + >:> mvRight + >:> aFlip + +toInner5 + = mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> aFlip + +toInner7 + = mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> aFlip + +toInner8 + = mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> mvRight + >:> aFlip + + +-- crc_checksum_8 crc_polynom polySkip start rest padding +crc_checksum_8 crc_polynom polySkip start rest padding + = (padding &&& aId) + >>> toInner8 + + >>> (start &&& rest) + >>> first (crc_polynom) + + >>> step + >>> step + >>> step + >>> step + >>> step + >>> step + + >>> aFlip + >>> polySkip + >>> crc_polynom + + where step = a_aBC2ABc + >>> first + ( aFlip + >>> polySkip + >>> crc_polynom + ) + + +-- crc_test +-- = crc_checksum_8 +-- inner_crc_3ord +-- toInner3 +-- (second (second (second aFst))) +-- (aSnd >>> aSnd >>> aSnd >>> aSnd) +-- (aConst (False, (False, False))) + + +-- crc_checksum_ccitt_8 :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, (b, (b, (b, b))))))) (b, (b, (b, b))) +crc_checksum_ccitt_8 :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) (Bool, (Bool, (Bool, Bool))) +crc_checksum_ccitt_8 + = crc_checksum_8 + crc_polynom_ccitt + toInner4 + (second.second.second.second $ aFst) + (aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd) + (aConst (False, (False, (False, False)))) + +-- crc_checksum_usb_8 :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, (b, (b, (b, b))))))) (b, (b, (b, (b, b)))) +-- crc_checksum_usb_8 +-- = crc_checksum_8 +-- crc_polynom_usb +-- toInner5 +-- (second.second.second.second.second $ aFst) +-- (aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd) +-- (aConst (False, (False, (False, (False, False))))) + +-- crc_checksum_sdmmc_8 :: (Arrow a, Bits b) => Grid a (b, (b, (b, (b, (b, (b, (b, b))))))) (b, (b, (b, (b, (b, (b, b)))))) +-- crc_checksum_sdmmc_8 +-- = crc_checksum_8 +-- crc_polynom_sdmmc +-- toInner7 +-- (second.second.second.second.second.second.second $ aFst) +-- (aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd >>> aSnd) +-- (aConst (False, (False, (False, (False, (False, (False, False))))))) + diff --git a/src/System/ArrowVHDL/Circuit.hs b/src/System/ArrowVHDL/Circuit.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit.hs @@ -0,0 +1,16 @@ +module System.ArrowVHDL.Circuit + ( Grid(..) + , runGrid + + , Stream(..) + + , Show(..) + ) +where + +-- Modul: System.ArrowVHDL.Circuit +-- stellt ein Wrapper-Modul nach dem Fassaden Entwurfsmuster dar. + +import System.ArrowVHDL.Circuit.Grid +import System.ArrowVHDL.Circuit.Stream +import System.ArrowVHDL.Circuit.Show diff --git a/src/System/ArrowVHDL/Circuit/Arrow.hs b/src/System/ArrowVHDL/Circuit/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Arrow.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + +module System.ArrowVHDL.Circuit.Arrow + ( Arrow(..) + , ArrowLoop(..) + , ArrowCircuit(..) + , ArrowChoice(..) + , returnA + , movebrc + , backbrc + , swapsnd + ) +where + + +import Prelude (id) + +import System.ArrowVHDL.Circuit.Arrow.Class +import System.ArrowVHDL.Circuit.Arrow.Instance + + + +-- | 'returnA' is a standard arrow-function that is similar to return in the monad context +returnA :: (Arrow a) => a b b +returnA = arr id + + + + +-- | 'movebrc', 'backbrc' and 'swapsnd' are functions that change the order of tuples +movebrc :: ((a, b), c) -> (a, (b, c)) +movebrc ~(~(x, y), sg) = (x, (y, sg)) + +backbrc :: (a, (b, c)) -> ((a, b), c) +backbrc ~(x, ~(y, sg)) = ((x, y), sg) + +swapsnd :: ((a, b), c) -> ((a, c), b) +swapsnd ~(~(x, y), sg) = ((x, sg), y) diff --git a/src/System/ArrowVHDL/Circuit/Arrow/Class.hs b/src/System/ArrowVHDL/Circuit/Arrow/Class.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Arrow/Class.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + + +-- Das Modul \hsSource{Circuit.Arrowdefinition} beschreibt, wie die Arrow-Klasse zu implementieren sind um damit später Schaltkreise beschreiben, +-- bearbeiten oder benutzen zu können. + +module System.ArrowVHDL.Circuit.Arrow.Class + ( Arrow(..) + , ArrowLoop(..) + , ArrowCircuit(..) + , ArrowChoice(..) + ) +where + + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: +import Prelude hiding (id, (.)) +import qualified Prelude as Pr + +import Control.Category + +import System.ArrowVHDL.Circuit.ShowType + + + +-- Durch die Angabe von Präzedenzen lassen sich Operatoren ohne Klammer schreiben. Dies hilft bei der Leserlichkeit von Quellcode. Folgende +-- Präzedenzen werden festgelegt: + + +infixr 3 *** +infixr 3 &&& + + +-- Zunächst einmal müssen die Klassen definiert werden. Diese Vorgaben müssen von allen Instanzdefinitionen befolgt werden. + + +-- Hier folgt die Klassendefinition eines Arrows. Anzumerken ist, dass diese Klassendefinition geringfügig von der Standard-Definition +-- abweicht. Die Arrow-Klasse wird hier in der \hsSource{arr} Funktion soweit eingeschränkt, dass nur Funktionen (\hsSource{(b -> c)}) von +-- \hsSource{arr} akzeptiert werden, die Mitglied der Typklasse \hsSource{ShowType b c} sind. + + +class (Category a) => Arrow a where + arr :: (ShowType b c) => (b -> c) -> a b c + first :: a b c -> a (b, d) (c, d) + second :: a b c -> a (d, b) (d, c) + second f = arr swap >>> first f >>> arr swap + where swap :: (b, c) -> (c, b) + swap ~(x, y) = (y, x) + (***) :: a b c -> a b' c' -> a (b, b') (c, c') + f *** g = first f >>> second g + (&&&) :: a b c -> a b c' -> a b (c, c') + f &&& g = arr (\b -> (b, b)) >>> f *** g + + + +-- Weitere Arrow Instanzen sind \hsSource{ArrowLoop}. Hierbei handelt es sich um Arrow, die sich selbst wieder aufrufen können, und somit einen +-- Fixpunkt in der Arrow-Funktion versuchen zu finden. + + +class (Arrow a) => ArrowLoop a where + loop :: a (b,d) (c,d) -> a b c + + + +-- Mit \hsSource{ArrowCircuit} sind die Arrows gemeint, die sich als getaktete Schaltung darstellen lassen. Definiert werden muss hier +-- lediglich, was ein Takt ist. + + +class (ArrowLoop a) => ArrowCircuit a where + delay :: b -> a b b + + + +-- Eine weitere Typklasse ist \hsSource{ArrowChoice}. Mit Arrow-Choice ist es Möglich, Varianten der selben Lösung parallel nebeneinander +-- erzeugen zu lassen. + + +class (Arrow a) => ArrowChoice a where + left :: a b c -> a (Either b d) (Either c d) + right :: a b c -> a (Either d b) (Either d c) + (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c') + (|||) :: a b d -> a c d -> a (Either b c ) d + + right f = arr mirror >>> left f >>> arr mirror + where mirror :: Either x y -> Either y x + mirror (Left x) = (Right x) + mirror (Right x) = (Left x) + + f +++ g = left f >>> right g + + f ||| g = f +++ g >>> arr untag + where untag (Left x) = x + untag (Right x) = x + diff --git a/src/System/ArrowVHDL/Circuit/Arrow/Helpers.hs b/src/System/ArrowVHDL/Circuit/Arrow/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Arrow/Helpers.hs @@ -0,0 +1,48 @@ +-- Das Modul \hsSource{Circuit.Arrow.Helpers} beschreibt Hilfsfunktionen, zur Arrow-Gestaltung. + + +module System.ArrowVHDL.Circuit.Arrow.Helpers +where + + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: + + +import Control.Category + +import System.ArrowVHDL.Circuit.Arrow +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Grid +import System.ArrowVHDL.Circuit.Stream +import System.ArrowVHDL.Circuit.Graphs + + + + +-- Weitere Hilfsfunktionen werden notwendig, um schon bestehende \hsSource{Grid}-Arrows mit Schaltkreis Beschreibungen anzureichern. + + +insert :: b -> (a, b) -> (a, b) +insert sg ~(x, _) = (x, sg) + +insEmpty = insert emptyCircuit { nodeDesc = nodedesc } + where nodedesc = MkNode { label = "eeeempty", nodeId = 0, sinks = mkPins 1, sources = mkPins 3 } + +augment :: (Arrow a) => CircuitDescriptor -> a b c -> Grid a b c +augment sg f = GR (f, sg) + + + + +-- Zu guter letzt werden noch Funktionen benötigt, die bei der Umstrukturierung von Daten gebraucht werden. + + +movebrc :: ((a, b), c) -> (a, (b, c)) +movebrc ~(~(x, y), sg) = (x, (y, sg)) + +backbrc :: (a, (b, c)) -> ((a, b), c) +backbrc ~(x, ~(y, sg)) = ((x, y), sg) + +swapsnd :: ((a, b), c) -> ((a, c), b) +swapsnd ~(~(x, y), sg) = ((x, sg), y) diff --git a/src/System/ArrowVHDL/Circuit/Arrow/Instance.hs b/src/System/ArrowVHDL/Circuit/Arrow/Instance.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Arrow/Instance.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + + +-- Das Modul \hsSource{Circuit.Arrowdefinition} beschreibt, wie die +-- Arrow-Klasse zu implementieren sind um damit später Schaltkreise +-- beschreiben, bearbeiten oder benutzen zu können. + + +module System.ArrowVHDL.Circuit.Arrow.Instance +where + + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu +-- können: +import System.ArrowVHDL.Circuit.Arrow.Class + + + +-- Da die folgende Arrow-Instanz nicht zur Ausführung benötigt wird, +-- sondern damit das Typsystem an anderer Stelle den richtigen Typ +-- ableiten kann, ist es möglich diese Instanz als \begriff{dummy +-- Instance} zu definieren. Dies bedeutet, dass die Instanz keine +-- definierten Methoden besitzt. Der Kompiler warnt die nicht +-- vorhandenen Methoden zwar an, es bleibt allerdings bei der Warnung. + + +instance Arrow (->) where + arr f = f + first f = (\(x, y) -> (f x, y)) + +-- Im folgenden wird eine Instanz der \hsSource{ArrowLoop}-Klasse für +-- einfache Funktionsauswertung definiert. Auch hier reicht eine +-- \begriff{dummy}-Definition für das Typsystem. + +instance ArrowLoop (->) where +-- loop f b = let (c, d) = f (b, d) in c + + diff --git a/src/System/ArrowVHDL/Circuit/Auxillary.hs b/src/System/ArrowVHDL/Circuit/Auxillary.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Auxillary.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE Arrows, + RankNTypes #-} +module System.ArrowVHDL.Circuit.Auxillary +where + +import Data.List (union, groupBy, isInfixOf) +import Data.Maybe +import Data.Either +import Control.Monad (msum) + +import GHC.Exts (sortWith) + +import System.ArrowVHDL.Circuit.Grid +import System.ArrowVHDL.Circuit.Stream + +import Control.Category +import System.ArrowVHDL.Circuit.Arrow + +import System.ArrowVHDL.Circuit.Grid +import System.ArrowVHDL.Circuit.Stream + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Show +import System.ArrowVHDL.Circuit.Tests +import System.ArrowVHDL.Circuit.Splice +import System.ArrowVHDL.Circuit.Sensors +import System.ArrowVHDL.Circuit.Workers + +import System.ArrowVHDL.Circuit.Graphs (emptyCircuit) + + + +-- 'nextID' is function that gets a list of component numbers and generates the next valid one +nextID :: [CompID] -> CompID +nextID [] = 0 +nextID [cid] = cid + 1 +nextID cids = nextID [foldl max 0 cids] + + + +-- %%% Unter Ferner liefen XXX +-- Die Funktion \hsSource{onlyInnerEdges} +-- filtert aus einer Liste von Kanten genau diese Kanten heraus, die +-- die internen Kanten im Schaltkreis darstellen. Die Ergebnismenge +-- enthält keine Ein- und Ausgehenden Kanten. +onlyInnerEdges :: [Edge] -> [Edge] +onlyInnerEdges es = es' + where es' = filter notIO $ es + notIO :: Edge -> Bool + notIO (MkEdge (Nothing, _) _) = False + notIO (MkEdge _ (Nothing, _)) = False + notIO _ = True + + + +-- Typischerweise verwendet man den Begriff \begriff{Synthese} in der +-- Hardware-Community für den Prozess, aus einer Modellhaften +-- Hardwarebeschreibung heraus tatsächlichen Hardwarecode +-- (beispielsweise VHDL) zu erzeugen. Daneben ist auch die +-- \begriff{Simulation} von Hardwaremodellen notwendig, um die +-- entworfenen Modelle vor der Realisierung überprüfen zu können. +-- +-- +-- Die beiden Prozesse lassen sich auch auf das \hsSource{Grid}-Arrow +-- Modell übertragen. So stellt \hsSource{synthesize} eine Funktion +-- dar, die aus einem gegebenen \hsSource{Grid} die fertige +-- Hardwarebeschreibung \footnote{in diesem Fall ausgeliefert in VHDL} +-- ausliest. Die Simulation wird mittels der Funktion +-- \hsSource{simulate} abgebildet. Diese Funktion liest nun aus einem +-- \hsSource{Grid} den Arrow heraus und überführt diesen in einen +-- \hsSource{Stream}-Arrow, der dann mit einem kontinuierlichem +-- Datenstrom simuliert werden kann. + + + +testPreSynth :: (Arrow a) => Grid a b c -> (a b c, CircuitDescriptor) +testPreSynth (GR tuple) = tuple + +test2PreSynt = snd + +--synthesize :: (Arrow a) => Grid a b c -> CircuitDescriptor +--synthesize (GR (_, cd)) = flatten cd +-- %%% TODO : Flatten won't work with Looping-Stuff ... +synthesize :: Grid (->) b c -> CircuitDescriptor +-- synthesize :: Grid (->) b c -> CircuitDescriptor +synthesize (GR (_, cd)) = cd +--synthesize (GR x) = snd x + + +simulate :: Grid (->) b c -> Stream b c +simulate f = arr (toFunctionModel f) + + + +-- Um einen \hsSource{Grid}-Arrow kombinatorisch auszuwerten, +-- existiert die Hilfsfunktion \hsSource{toFunctionModel}, die ein +-- Synonym für \hsSource{runGrid} ist. + + +toFunctionModel :: Grid (->) b c -> (b -> c) +toFunctionModel = runGrid + + + +-- %%% TODO : Ist synthesize mit unit () möglich? +-- %%% TODO : Keine zufälligen daten ... +-- %%% TODO : Frage nach simulate / synthesize => right ... +-- %%% TODO : _kritische_pfad_analyse_ / ... + + + + +-- Weitere Hilfsfunktionen werden notwendig, um schon bestehende \hsSource{Grid}-Arrows mit Schaltkreis Beschreibungen anzureichern. + + +insert :: b -> (a, b) -> (a, b) +insert sg ~(x, _) = (x, sg) + +insEmpty = insert emptyCircuit { nodeDesc = MkNode { label = "eeeempty", nodeId = 0, sinks = mkPins 1, sources = mkPins 3 } } + +augment :: (Arrow a) => CircuitDescriptor -> a b c -> Grid a b c +-- augment = ( flip Prelude.. curry ) GR +augment cd_f f = GR (f, cd_f) + diff --git a/src/System/ArrowVHDL/Circuit/Defaults.hs b/src/System/ArrowVHDL/Circuit/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Defaults.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, RebindableSyntax #-} +module System.ArrowVHDL.Circuit.Defaults where + +import Control.Category +import Prelude hiding (id, (.)) +import qualified Data.Bits as B -- (shiftL, shiftR, xor, (.&.)) + +import System.ArrowVHDL.Circuit + +import System.ArrowVHDL.Circuit.Grid + +import System.ArrowVHDL.Circuit.Arrow + +import System.ArrowVHDL.Circuit.Auxillary +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Graphs +import System.ArrowVHDL.Circuit.Show + + +type KeyChunk = Int +type ValChunk = Int +type Key = (KeyChunk, KeyChunk, KeyChunk, KeyChunk) +type KeyHalf = (KeyChunk, KeyChunk) +type Value = (ValChunk, ValChunk) + +-- xor :: Bool -> Bool -> Bool +-- xor x y | x == True && y == False = True +-- | x == False && y == True = True +-- | otherwise = False + +oneNodeCircuit :: String -> CircuitDescriptor +oneNodeCircuit s = emptyCircuit { nodeDesc = emptyNodeDesc { label = s } } + +aId :: (Arrow a) => Grid a b b +aId + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "ID" + , sinks = mkPins 1 + , sources = mkPins 1 + } + , cycles = 1 + , space = 1 + } + $ arr id + + +aConst :: (Arrow a, Show b) => b -> Grid a c b +aConst x + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "CONST_" ++ (show x) + , sinks = mkPins 1 -- a sink is needed for the rewire-function to work properly (TODO: is this ok?) + , sources = mkPins 1 + } + , cycles = 0 + , space = 1 + } + $ arr (const x) + + +(.&.) :: Bool -> Bool -> Bool +True .&. True = True +_ .&. _ = False + +(.|.) :: Bool -> Bool -> Bool +False .|. False = False +_ .|. _ = True + +xor :: Bool -> Bool -> Bool +xor True False = True +xor False True = True +xor _ _ = False + +-- shiftL8 :: (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool)))))))) +-- -> Int +-- -> (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool)))))))) +-- shiftL8 (x1, (x2, (x3, (x4, (x5, (x6, (x7, (x8)))))))) i +-- | i == 0 +-- = (x1, (x2, (x3, (x4, (x5, (x6, (x7, (x8)))))))) +-- | i == 1 +-- = (x2, (x3, (x4, (x5, (x6, (x7, (x8, (False)))))))) +-- | i == 2 +-- = (x3, (x4, (x5, (x6, (x7, (x8, (False, (False)))))))) +-- | i == 3 +-- = (x4, (x5, (x6, (x7, (x8, (False, (False, (False)))))))) +-- | i == 4 +-- = (x5, (x6, (x7, (x8, (False, (False, (False, (False)))))))) +-- | i == 5 +-- = (x6, (x7, (x8, (False, (False, (False, (False, (False)))))))) +-- | i == 6 +-- = (x7, (x8, (False, (False, (False, (False, (False, (False)))))))) +-- | i == 7 +-- = (x8, (False, (False, (False, (False, (False, (False, (False)))))))) +-- | i == 8 +-- = (False, (False, (False, (False, (False, (False, (False, (False)))))))) +-- shiftL = shiftL8 + +-- shiftR8 :: (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool)))))))) +-- -> Int +-- -> (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool)))))))) +-- shiftR8 (x1, (x2, (x3, (x4, (x5, (x6, (x7, (x8)))))))) i +-- | i == 0 +-- = (x1, (x2, (x3, (x4, (x5, (x6, (x7, (x8)))))))) +-- | i == 1 +-- = (False, (x1, (x2, (x3, (x4, (x5, (x6, (x7)))))))) +-- | i == 2 +-- = (False, (False, (x1, (x2, (x3, (x4, (x5, (x6)))))))) +-- | i == 3 +-- = (False, (False, (False, (x1, (x2, (x3, (x4, (x5)))))))) +-- | i == 4 +-- = (False, (False, (False, (False, (x1, (x2, (x3, (x4)))))))) +-- | i == 5 +-- = (False, (False, (False, (False, (False, (x1, (x2, (x3)))))))) +-- | i == 6 +-- = (False, (False, (False, (False, (False, (False, (x1, (x2)))))))) +-- | i == 7 +-- = (False, (False, (False, (False, (False, (False, (False, (x1)))))))) +-- | i == 8 +-- = (False, (False, (False, (False, (False, (False, (False, (False)))))))) +-- shiftR = shiftR8 + +-- aAnd :: (Arrow a, Bits b) => Grid a (b, b) (b) +aAnd :: (Arrow a) => Grid a (Bool, Bool) (Bool) +aAnd + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "AND" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (uncurry (.&.)) + + +-- aOr :: (Arrow a, Bits b) => Grid a (b, b) (b) -- :: (Arrow a) => Grid a (Bool, Bool) (Bool) +aOr :: (Arrow a) => Grid a (Bool, Bool) (Bool) +aOr + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "OR" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (uncurry (.|.)) + + +aNot :: (Arrow a) => Grid a (Bool) (Bool) +aNot + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "NOT" + , sinks = mkPins 1 + , sources = mkPins 1 + } + , cycles = 1 + , space = 2 + } + $ arr (not) + + +aBXor :: (Arrow a, B.Bits b) => Grid a (b, b) (b) -- :: (Arrow a) => Grid a (Bool, Bool) (Bool) +aBXor + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "XOR" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (uncurry B.xor) + +aXor :: (Arrow a) => Grid a (Bool, Bool) (Bool) +aXor + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "XOR" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (uncurry xor) + + +-- aFst :: (Arrow a, Bits b) => Grid a (b, c) (b) +aFst :: (Arrow a) => Grid a (b, c) (b) +aFst + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "FST" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (fst) + + +-- aSnd :: (Arrow a, Bits c) => Grid a (b, c) (c) +aSnd :: (Arrow a) => Grid a (b, c) (c) +aSnd + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SND" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (snd) + + +aShiftL :: (Arrow a, B.Bits b) => Grid a (b, Int) (b) +-- aShiftL :: (Arrow a) => Grid a ((Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))), Int) (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) +aShiftL + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SHIFTL" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 6 + } + $ arr (uncurry B.shiftL) + +aShiftR :: (Arrow a, B.Bits b) => Grid a (b, Int) (b) +-- aShiftR :: (Arrow a) => Grid a ((Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))), Int) (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) +aShiftR + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SHIFTR" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 6 + } + $ arr (uncurry B.shiftR) + +aAdd :: (Arrow a, Num b) => Grid a (b, b) (b) +aAdd + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "ADD" + , sinks = mkPins 2 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (uncurry (+)) + +aFlip :: (Arrow a) => Grid a (b, c) (c, b) +aFlip + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "FLIP" + , sinks = mkPins 2 + , sources = mkPins 2 + } + , cycles = 1 + , space = 4 + } + $ arr (\(x, y) -> (y, x)) + +aSwapSnd :: (Arrow a) => Grid a ((b, c), d) ((b, d), c) +aSwapSnd + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SWPSND" + , sinks = mkPins 2 + , sources = mkPins 2 + } + , cycles = 1 + , space = 6 + } + $ arr (\((x, y), z) -> ((x, z), y)) + +aAssocRight = a_ABc2aBC +aAssocLeft = a_aBC2ABc + +a_ABc2aBC :: (Arrow a) => Grid a ((b, c), d) (b, (c, d)) +a_ABc2aBC + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "ABc2aBC" + , sinks = mkPins 2 + , sources = mkPins 2 + } + , cycles = 1 + , space = 6 + } + $ arr (\((x, y), z) -> (x, (y, z))) + +a_aBC2ABc :: (Arrow a) => Grid a (b, (c, d)) ((b, c), d) +a_aBC2ABc + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "aBC2ABc" + , sinks = mkPins 2 + , sources = mkPins 2 + } + , cycles = 1 + , space = 6 + } + $ arr (\(x, (y, z)) -> ((x, y), z)) + + +-- |'aDistr' defines an distributivity of an expression ... +-- (x,(a,b)) -> ((x,a), (x,b)) + +-- aDistr :: (Arrow a, Bits b, Bits c, Bits d) => Grid a (b, (c, d)) ((b, c), (b, d)) +aDistr :: (Arrow a) => Grid a (b, (c, d)) ((b, c), (b, d)) +aDistr + = aDup + >>> second aFst *** second aSnd + +-- |'aDdistr' is the reverse operation to the Distr operation + +-- aDdistr :: (Arrow a, Bits b, Bits c, Bits d, Bits e) => Grid a ((b, c), (d, e)) ((b, d), (c, e)) +aDdistr :: (Arrow a) => Grid a ((b, c), (d, e)) ((b, d), (c, e)) +aDdistr + = aSwapSnd + >>> a_aBC2ABc *** aId + >>> a_ABc2aBC + >>> aId *** aFlip + +aShiftL4 :: (Arrow a, B.Bits b) => Grid a b b +-- aShiftL4 :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) +aShiftL4 + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SHIFTL4" + , sinks = mkPins 1 + , sources = mkPins 1 + } + , cycles = 1 + , space = 6 + } + $ arr (flip B.shiftL 4) + +aShiftR5 :: (Arrow a, B.Bits b) => Grid a b b +-- aShiftR5 :: (Arrow a) => Grid a (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool))))))) +aShiftR5 + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "SHIFTR5" + , sinks = mkPins 1 + , sources = mkPins 1 + } + , cycles = 1 + , space = 6 + } + $ arr (flip B.shiftR 5) + +-- aShiftL4addKey :: (Arrow a) => Grid a (ValChunk, KeyChunk) Int +-- aShiftL4addKey +-- = first aShiftL4 +-- >>> aAdd + +-- aShiftR5addKey :: (Arrow a) => Grid a (ValChunk, KeyChunk) Int +-- aShiftR5addKey +-- = first aShiftR5 +-- >>> aAdd + + +--- NOTE: Hier ist ein schönes Problem aufgetreten: +-- da weiter unten arr ... >>> aAdd verwendet wird, und arr ... vom Typ Arrow a ist +-- aber aAdd vom Typ Grid a ist, gibt's nen type-mismatch... entweder aAdd muss auf Arrow a +-- runtergebrochen werden, oder arr ... muss vorher schon in einen Grid gehoben werden :) +-- +-- So oder so, schön ;) +--aAddMagic :: (Arrow a) => Grid a ValChunk Int +aXorMagic + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "ADDMAGIC" + , sinks = mkPins 1 + , sources = mkPins 1 + } + , cycles = 1 + , space = 4 + } + $ arr (\x -> (x, 2654435769)) >>> aBXor + +--aDup :: (Arrow a) => Grid a b (b, b) +aDup + = augment + emptyCircuit + { nodeDesc = emptyNodeDesc + { label = "DUP" + , sinks = mkPins 1 + , sources = mkPins 2 + } + , cycles = 1 + , space = 4 + } + $ arr (\(x) -> (x, x)) + +aRegister :: (Arrow a) => Grid a b b +aRegister + = augment + ( mkRegister $ emptyNodeDesc + { sinks = mkPins 1 + , sources = mkPins 1 + } + ) + $ arr id + + +-- aL_headtail :: (Arrow a) => Grid a ([b]) (b, [b]) +-- aL_headtail +-- = augment +-- emptyCircuit +-- { nodeDesc = emptyNodeDesc +-- { label = "listHEADTAIL" +-- , sinks = mkPins 1 +-- , sources = mkPins 2 +-- } +-- , cycles = 2 +-- , space = 16 +-- } +-- $ arr (\(x:xs) -> (x, xs)) diff --git a/src/System/ArrowVHDL/Circuit/Descriptor.hs b/src/System/ArrowVHDL/Circuit/Descriptor.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Descriptor.hs @@ -0,0 +1,236 @@ +-- Im folgenden wird der das Modul \hsSource{Circuit.Descriptor} beschrieben + +module System.ArrowVHDL.Circuit.Descriptor +where + + +-- \subsection{Typen mit neuen Namen} +-- Zunächst werden grundlegende Typaliasse vergeben, die im gesamten +-- Quelltext Anwendung finden. + + +-- Jede Hardware Komponente besitzt Pins verschiedener Art, darunter +-- ein- und ausgehende. Diese sind durchnummeriert und werden über +-- ihre Nummer, die als Integer abgebildet wird, identifiziert. Für +-- die Komponenten ID gilt dies ebenfalls. +-- +-- +-- Daneben wird der Typ für einen \begriff{Clock-Cycle} definiert. In +-- diesem Fall wird ein Integer dafür verwendet. Auch die Fläche wird +-- mit einem Integer beschrieben. Für die Fläche besagt der Wert, +-- wieviele \begriff{Zellen} der Baustein belegt. %%% TODO : Was ist +-- eine Zelle? + +type PinID = Int +type Pins = [PinID] + +type ID = Int +type CompID = ID + +type Tick = Int +type Area = Int + + + +-- Eine Kante ist eine Verbindung zwischen zwei \hsSource{Pins}, dabei +-- müssen die beiden \hsSource{Pins} nicht unbedingt zu +-- unterschiedlichen Komponenten gehören \footnote{Beispielsweise bei +-- zyklischen Schaltungen}. Das Tupel aus \hsSource{PinID} und +-- \hsSource{CompID} identifiziert einen Pin. Da auch Kanten +-- abgebildet werden sollen, die nach außerhalb der aktuellen +-- Komponente gehen sollen, ist es notwendig, die \hsSource{CompID} +-- als \hsSource{Maybe} Typ zu beschreiben. Das Tupel wird im +-- folgenden mit \hsSource{Anchor} bezeichnet. + +type Anchor = (Maybe CompID, PinID) +type SinkAnchor = Anchor +type SourceAnchor = Anchor + + +-- Außerdem wurden noch zwei weitere Aliasse vergeben, die Eingehende +-- (\hsSource{SinkAnchor}) und Ausgehende (\hsSource{SourceAnchor}) +-- Pins voneinander unterscheiden. +-- +-- \subsection{Benannte Typen} Um die Graph-Struktur später in +-- Sourcecode überführen zu können, benötigt man Namen für +-- \hsSource{Anchor} und \hsSource{Edges} sowie Lookup-Tabellen, in +-- denen dann die Namen abgelegt werden. Die Typaliasse hierfür werden +-- hier direkt definiert. + +type NamedPins = [(String, Anchor)] +type NamedSigs = [(String, Edge)] +type NamedSnks = NamedPins +type NamedSrcs = NamedPins +type NamedIOs = (NamedSnks, NamedSrcs) + +nameSig = "i" +nameExI = "inc" +nameExO = "out" +nameInI = "e" +nameInO = "a" + + + +-- \subsection{Schaltungsbeschreibung} Jede Komponente die durch einen +-- Arrow repräsentiert wird, hat zusätzliche Attribute, die nicht in +-- dem Arrow selber stehen. Diese Attribute werden auch nicht für alle +-- Arrow-Klassen Instanzen benötigt. Daher sind diese lose an den +-- Arrow gekoppelt. \footnote{Arrow und Attribute werden in einem +-- Tupel zusammengefasst} +-- +-- %%% TODO : is Circuit the right name? Component is better or: Chip / Device / Module / what ever +-- %%% TODO : MkSG und NoSG sind die falschen Konstruktoren + + + +-- \subsection{Pins} Zunächst werden grundlegende Typaliasse vergeben, +-- die im gesamten Quelltext Anwendung finden. + + +-- Jede Hardware Komponente besitzt Pins verschiedener Art, darunter +-- Eingabe- und Ausgabepins. + +-- \subsection{Schaltungsbeschreibung} Jede Komponente die durch einen +-- Arrow repräsentiert wird, hat zusätzliche Attribute, die nicht in +-- dem Arrow selber stehen. Diese Attribute werden auch nicht für alle +-- Arrow-Klassen Instanzen benötigt. Daher sind diese lose an den +-- Arrow gekoppelt. \footnote{Arrow und Attribute werden in einem +-- Tupel zusammengefasst} + + +-- Hier wird unterschieden zwischen Kombinatorischen Schaltungen +-- \hsSource{MkCombinatorial}, Registern \hsSource{MkRegister} und +-- nicht vorhandenen Schaltungen \hsSource{NoDescriptor}. %%% TODO : +-- Wie fließt hier MkComposite rein? + + +-- Ein Register unterscheidet sich von einer kombinatorischen +-- Schaltung, teilweise gibt es Gemeinsamkeiten. Diese Gemeinsamkeiten +-- werden über den Datentyp \hsSource{NodeDescriptor} verkörpert. + + + +data NodeDescriptor + = MkNode + { label :: String + , nodeId :: ID + , sinks :: Pins + , sources :: Pins + } + deriving (Eq) + + + + +-- Der \hsSource{NodeDescriptor} taucht in der Definition eines +-- Schaltkreises, aber auch in der Definition eines Registers, auf. + + +data CircuitDescriptor + = MkCombinatorial + { nodeDesc :: NodeDescriptor + , nodes :: [CircuitDescriptor] + , edges :: [Edge] + , cycles :: Tick + , space :: Area + } + + | MkRegister + { nodeDesc :: NodeDescriptor + , bits :: Int + } + + | MkLoop + { nodeDesc :: NodeDescriptor + , nodes :: [CircuitDescriptor] + , edges :: [Edge] + , space :: Area + } + + | MkComposite + { composite :: [CircuitDescriptor] + } + + | NoDescriptor + deriving (Eq) + +type Netlist = CircuitDescriptor + + +-- In Haskell lassen sich die Komponenten Attribute über einen +-- Summentyp abgebildet. Dieser Datentyp ist ein fundamentaler +-- Datentyp, da er gleichberechtigt neben der eigentlichen +-- Funktionalität steht. Er besitzt einen Bezeichner \hsSource{label}, +-- sowie eine eindeutige ID \hsSource{nodeId}. Zusätzlicher sind die +-- Ein- sowie die Ausgehenden Pins aufgeführt und auch die +-- verbindenden Kanten (\hsSource{edges}). +-- +-- +-- Jede Komponente kann durch untergeordnete Komponenten beschrieben +-- werden. Dies wird im Datentyp über die \hsSource{nodes} Liste +-- abgebildet. Ist die Komponenten atomar, so enthält dieses Datum +-- die leere Liste. Der Konstruktor \hsSource{NoSG} ist analog zu +-- $\varnothing$. %%% TODO : Mathematisch erklären warum {} benötigt +-- wird +-- +-- +-- Um zu verhindern, dass ungültige Schaltungsbeschreibungen erzeugt +-- werden, können \begriff{smart constructor}s eingesetzt +-- werden. Hierbei handelt es sich um Funktionen, die analog zu den +-- Konstruktoren arbeiten. Diese unterscheiden sich darin, dass die +-- Konstruktoren jedes Datum erzeugen. Allerdings ist es häufig nicht +-- gewünscht, jedes Datum erzeugen zu können oder es ist gewünscht, +-- dass der Benutzer beim Versuch ein falsches Datum zu erzeugen, mit +-- einer Fehlermeldung konfrontiert wird. +-- +-- +-- Es folgt der Quellcode des \begriff{smart constructor}s für ein +-- Register. Hierbei ist nur darauf zu achten, dass dieses Register +-- keine ID bekommt, die schon einmal vergeben wurde. +-- +-- %%% TODO : error checking muss hier noch rein + + +mkRegister :: NodeDescriptor -> CircuitDescriptor +mkRegister nd + = MkRegister + { nodeDesc = nd { label = "REG" ++ (show $ nodeId nd) } + , bits = length $ sinks nd + } + + + +-- Zuletzt fehlt jetzt lediglich die Definition einer Kante. Eine +-- Kante kennt einen Quell-Pin sowie einen Ziel-Pin. + +data Edge + = MkEdge { sourceInfo :: SourceAnchor + , sinkInfo :: SinkAnchor + } + deriving (Eq) + + + +-- \subsection{Smarte Konstruktoren} In Haskell lassen sich Typen sehr +-- fein granular definieren. Für die Liste der Pins einer Schaltung +-- passt eine Liste von Integer-Werten sehr gut aber nicht perfekt. So +-- gibt es auch Integer-Listen mit keinem Inhalt. Wollte man das auf +-- der Typebene verhindern, so würde dies einen Overhead erfordern, +-- der nicht im Verhältnis zu dem Nutzen stehen würde. Eine einfache +-- aber nützliche Alternative sind \begriff{smart +-- constructor}. Hierbei handelt es sich um einen Funktion, die als +-- Parameter alle Werte bekommt, die benötigt werden, um ein Datum des +-- gewünschten Types zu erzeugen. Die Funktion erzeugt dann ein +-- solches Datum und kann sich daneben auch noch um +-- Fehler-Behandlungen kümmern. %%% TODO : Boxed Types reference +-- +-- +-- Bei \hsSource{mkPins} handelt es sich um so einen \begriff{smart +-- Constructor}. Dieser erhält die Anzahl der benötigten Pins als +-- Parameter und erzeugt dann eine entsprechende Liste. + + +mkPins :: Int -> Pins +mkPins 0 = error $ show "It is not possible to generate a component with 0 pins" +mkPins n = [0..n-1] + diff --git a/src/System/ArrowVHDL/Circuit/EdgeTransit.hs b/src/System/ArrowVHDL/Circuit/EdgeTransit.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/EdgeTransit.hs @@ -0,0 +1,79 @@ +-- In diesem Modul wird ein Algebraischer Datentyp aufgebaut. Dieses Datum wird im Codegenerator zur Generierung des Zielcodes benötigt. Der % TODO : Referenz +-- Algebraische Datentyp besteht aus einem Tupel, dass aus einer Liste von Ankerpunkten sowie den dazugehörigen Namen, besteht. + + +module System.ArrowVHDL.Circuit.EdgeTransit +where + + + +-- Im späteren wird die Funktionen aus dem \ref{mod:Circuit.Descriptor} Modul benötigt, sowie die Funktion \hsSource{isJust} aus \hsSource{Data.Maybe}. + +import Data.Maybe (isJust) +import System.ArrowVHDL.Circuit.Descriptor + + +-- \subsection{Datenstruktur} +-- Die Zwischenstruktur \hsSource{NamedEdge} wird über ein Typalias definiert. Hierbei wird einem Namen eine Liste von Ankerpunkten zugeordnet. + +type NamedEdge = ([Anchor], String) + + + +-- \subsection{Funktionen} +-- Zu der Datenstruktur gehören folgende Funktionen: +-- \begin{itemize} +-- \item \hsSource{generateNamedEdges} \\ +-- Eine Funktion die aus einem Graphen eine Liste benannter Kanten erstellt +-- \item \hsSource{getAllEdgeNames} \\ +-- Eine Funktion welche eine Liste benannter Kanten nutzt, um eine Liste von Namen zu erstellen +-- \item \hsSource{getEdgeName} +-- Eine Funktion die einen Namen aus der Liste benannter Kanten und einem Ankerpunkt erzeugt +-- \end{itemize} + + + + +-- Die Funktion \hsSource{generateNamedEdges} filtert aus dem übergebenen \hsSource{CircuitDescriptor} die Kanten heraus. Von allen Kanten +-- werden die Kanten heraus gefiltert, die nach \begriff{außen} verbinden. Diese Kanten haben als Quell- oder Zielkomponente \hsSource{Nothing} +-- gesetzt. Die relevanten Kanten werden durchnumeriert und in der Form einer \hsSource{NamedEdge} zurückgeliefert. + +pre :: String +pre = nameSig + +generateNamedEdges :: CircuitDescriptor -> [NamedEdge] +generateNamedEdges g + = map (\(i, e) -> (sourceInfo e : sinkInfo e : [], pre ++ show i)) + $ zip [0..] relevantEdges + where relevantEdges = filter (\ (MkEdge (ci,_) (co,_)) + -> isJust ci && isJust co) + $ edges g + + + +-- \hsSource{getAllEdgeNames} filtert lediglich das zweite Datum aus dem Tupel heraus. + +getAllEdgeNames :: [NamedEdge] -> [String] +getAllEdgeNames = map snd + + + +-- Zum ermitteln des Namens einer Kante, die an einem bestimmten Ankerpunkt beginnt oder endet, wird ein Funktion \hsSource{getNamedEdge} +-- definiert. Hierzu wird überprüft, ob der übergebene Ankerpunkt in einer der benannten Kanten vorkommt. Ist dies der Fall, wird das erste +-- Element der Ergebnisliste zurückgeliefert. %%% TODO : ist der Anker nicht vorhanden, erzeugt das eine ``empty List'' exception + +getNamedEdge :: [NamedEdge] -> Anchor -> NamedEdge +getNamedEdge nedgs ap + = head + $ filter (\(aps, _) -> ap `elem` aps) + $ nedgs + + + +-- Um nur den Namen einer Kante zu ermitteln, die einen bestimmten Ankerpunkt verbindet, wir die Funktion \hsSource{getEdgeName} definiert. +-- Diese filtert den zweiten Wert des Ergebnisstupels von \hsSource{getNamedEdge} heraus und liefert ihn als Rückgabe. + +getEdgeName :: [NamedEdge] -> Anchor -> String +getEdgeName nedgs ap + = snd $ getNamedEdge nedgs ap + diff --git a/src/System/ArrowVHDL/Circuit/Graphs.hs b/src/System/ArrowVHDL/Circuit/Graphs.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Graphs.hs @@ -0,0 +1,90 @@ +-- Dieser Abschnitt stellt einige Standard-Schaltkreise vor. Diese können als Grundlage für komplexere Schaltkreise herangezogen werden. + + +module System.ArrowVHDL.Circuit.Graphs +where + + + +-- Verwendet wird ausschließlich das Modul \ref{mod:Circuit.Graphs} (\hsSource{Circuit.Descriptor}). + + + +import System.ArrowVHDL.Circuit.Descriptor + + +-- \subsection{Leerer Schaltkreis} +-- Zunächst wird ein leerer Schaltkreis definiert, also ein Datum des Types \hsSource{CircuitDescriptor}. Dieses Datum enthält zwar die +-- korrekte Struktur, aber keine Nutzdaten. \hsSource{String}s sind leer \footnote{der \hsSource{String} ``...'' ist für das Debugging bewusst +-- nicht leer}, \hsSource{Integer} werden auf $0$ gesetzt und Listen sind jeweils leere Listen. +-- +-- +-- Da ein \hsSource{CircuitDescriptor} auch aus einem \hsSource{NodeDescriptor} aufgebaut ist, liegt es auf der Hand, auch einen leeren +-- \hsSource{NodeDescriptor} zu definieren. + + + +emptyNodeDesc :: NodeDescriptor +emptyNodeDesc + = MkNode { label = "..." + , nodeId = 0 + , sinks = [] + , sources = [] + } + + + + +-- Der leere Schaltkreis lässt sich jetzt über den leeren \hsSource{NodeDescriptor} beschreiben. + + +emptyCircuit :: CircuitDescriptor +emptyCircuit + = MkCombinatorial + { nodeDesc = emptyNodeDesc + , nodes = [] + , edges = [] + , cycles = 0 + , space = 0 + } + + +-- \subsection{Schaltkreis Modifikatoren} +-- Neben der leeren Schaltung werden weitere Schaltungen benötigt, die größtenteils Unterschiede im Namen und in der Anzahl der Ein- und +-- Ausgängen haben. Diese könnte man definieren, indem die Beschreibung der leeren Schaltung an den entsprechenden Stellen überschrieben wird. +-- Schöner ist es allerdings, wenn man hier auf Modifikatoren zurückgreifen kann, welche die Aufgabe übernehmen. Bei Änderungen an der +-- \hsSource{CircuitDescriptor} Struktur müssen dann nur die Modifikatoren verändert werden, nicht aber sämtliche Schaltungsdefinitionen. + + + +withLabel :: String -> CircuitDescriptor -> CircuitDescriptor +withLabel l cd = cd { nodeDesc = nd { label = l } } + where nd = nodeDesc cd + +sinkCount :: Int -> CircuitDescriptor -> CircuitDescriptor +sinkCount i cd = cd { nodeDesc = nd { sinks = [0..(i-1)] } } + where nd = nodeDesc cd + +sourceCount :: Int -> CircuitDescriptor -> CircuitDescriptor +sourceCount i cd = cd { nodeDesc = nd { sources = [0..(i-1)] } } + where nd = nodeDesc cd + + + +-- Mithilfe der Modifikatoren lassen sich nun die weiteren Schaltkreise definieren: + + +arrCircuit + = withLabel "-ARR-" . sinkCount 1 . sourceCount 1 $ emptyCircuit + +throughCircuit + = withLabel "(-)" . sinkCount 1 . sourceCount 1 $ emptyCircuit + +idCircuit + = withLabel "-ID-" . sinkCount 1 . sourceCount 1 $ emptyCircuit + +leftCircuit + = withLabel "(L)" $ emptyCircuit + +rightCircuit + = withLabel "(R)" $ emptyCircuit diff --git a/src/System/ArrowVHDL/Circuit/Grid.hs b/src/System/ArrowVHDL/Circuit/Grid.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Grid.hs @@ -0,0 +1,13 @@ +-- Das Modul \hsSource{Circuit.Grid} stellt ein Wrapper-Modul nach dem Fassaden Entwurfsmuster dar. + +module System.ArrowVHDL.Circuit.Grid + ( Grid(..) + , runGrid + ) +where + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: + +import System.ArrowVHDL.Circuit.Grid.Datatype +import System.ArrowVHDL.Circuit.Grid.Instance diff --git a/src/System/ArrowVHDL/Circuit/Grid/Datatype.hs b/src/System/ArrowVHDL/Circuit/Grid/Datatype.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Grid/Datatype.hs @@ -0,0 +1,28 @@ +-- Das Modul \hsSource{Circuit.Arrowdefinition} beschreibt, wie die +-- Arrow-Klasse zu implementieren sind um damit später Schaltkreise +-- beschreiben, bearbeiten oder benutzen zu können. + +module System.ArrowVHDL.Circuit.Grid.Datatype +where + +-- Folgenden Module werden benötigt, um den Datentyp definieren zu können: + +import Control.Arrow + +import System.ArrowVHDL.Circuit.Descriptor + + +-- Ein \hsSource{Grid} ist ein Datentyp, für den die Arrow-Klassen +-- implementiert werden. Man spricht dann von einem +-- \hsSource{Grid}-Arrow. Der Name \hsSource{Grid} soll dabei an ein +-- Steckbrett erinnern, auf denen man Bauteile anbringen und +-- miteinander verbinden kann. \hsSource{Grid} besitzt 3 Typvariablen +-- (\hsSource{a}, \hsSource{b}, \hsSource{c}), wobei \hsSource{a} die +-- jeweilige Arrow-Instanz repräsentiert (z.B. \hsSource{(->)}), +-- \hsSource{b} und \hsSource{c} stellen den Typ des Arrows dar. Die +-- Funktion \hsSource{(+1)} hat den Typ \hsSource{Int -> Int}. Dies +-- lässt sich auch in präfix-Notation schreiben \hsSource{(->) Int +-- Int} und ist damit analog zu den Typvariablen des \hsSource{Grid} +-- Types. + +newtype Grid a b c = GR (a b c, CircuitDescriptor) diff --git a/src/System/ArrowVHDL/Circuit/Grid/Instance.hs b/src/System/ArrowVHDL/Circuit/Grid/Instance.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Grid/Instance.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + +-- Das Modul \hsSource{Circuit.Grid.Instance} beschreibt, wie die +-- Arrow-Instanzen des Grid-Datentypes implementiert werden. + +module System.ArrowVHDL.Circuit.Grid.Instance +where + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu +-- können: + +import System.ArrowVHDL.Circuit.Grid.Datatype + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Graphs +import System.ArrowVHDL.Circuit.Workers (flatten) +import System.ArrowVHDL.Circuit.ShowType + +import Prelude hiding (id, (.)) +import qualified Prelude as Pr + +import Control.Category + +import System.ArrowVHDL.Circuit.Arrow + +import System.ArrowVHDL.Circuit.Splice + + +-- Bevor für den Typ \hsSource{Grid} eine Arrow-Instanz implementiert +-- werden kann, muss \hsSource{Grid} Mitglied der Typklasse +-- \hsSource{Category} sein. + +instance (Category a) => Category (Grid a) where + id + = id + + GR (f, cd_f) . GR (g, cd_g) + = GR $ (f . g, cd_g `connect` cd_f) + + +-- Im nächsten Schritt wird dann die Arrow-Instanz von \hsSource{Grid} +-- implementiert. Laut Definition ist ein Arrow vollständig definiert +-- durch die Funktionen \hsSource{arr} und \hsSource{first}. Alle +-- weiteren Funktion lassen sich aus diesen beiden ableiten. Da hier +-- aber die Kontrolle über die Implementierung jeder Funktion behalten +-- werden soll, ist hier eine Implementation für alle +-- einzel-Funktionen gegeben. + +instance (Arrow a) => Arrow (Grid a) where + arr f + = error $ "Can't construct arbitarly Hardware-Components" -- GR $ (arr f, showType f) + + first (GR (f, cd_f)) + = GR ( first f + , cd_f `combine` idCircuit + ) + + second (GR (g, cd_g)) + = GR ( second g + , idCircuit `combine` cd_g + ) + + GR (f, cd_f) &&& GR (g, cd_g) + = GR ( f &&& g + , cd_f `combine` cd_g + ) + + GR (f, cd_f) *** GR (g, cd_g) + = GR ( f *** g + , cd_f `combine` cd_g + ) + + +-- Die Definition von \hsSource{ArrowLoop} ist dann notwendig, wenn +-- Schleifen abgebildet werden sollen. Hierzu ist die Implementation +-- einer einzigen Funktion notwendig, nämlich der \hsSource{loop :: a +-- (b, d) (c, d) -> a b c} notwendig. +-- +-- %%% TODO : Ersetzte diese Hardcoding version in eine, die +-- vielleicht ein wenig vergebender ist ;) + +instance (ArrowLoop a) => ArrowLoop (Grid a) where + loop (GR (f, cd_f)) = GR (loop f, loopWithRegister cd_f) + + + +instance (ArrowCircuit a) => ArrowCircuit (Grid a) where + delay x = GR (delay x, mkRegister $ MkNode "" 0 (mkPins 1) (mkPins 1)) + + + +-- Um den \hsSource{Grid}-Arrow zu \hsSource{ArrowChoice} hinzufüge, +-- so ist die Implementierung von \hsSource{ArrowChoice} für +-- \hsSource{Grid} notwendig. +-- +-- instance (Arrow a) => ArrowChoice (Grid a) where +-- left f = f +++ arr id +-- right g = arr id +++ g +-- f +++ g = (Left . f) ||| (Right . g) +-- f ||| g = either + + +-- Zu dem \hsSource{Grid}-Arrow gehört außerdem noch eine Funktion, +-- die den \hsSource{Grid}-Typ auspacken kann und dann ``ausführen'' +-- kann. + +runGrid :: (Arrow a) => Grid a b c -> a b c +runGrid (GR (f, _)) = f diff --git a/src/System/ArrowVHDL/Circuit/IEEE_STD_LOGIC_1164.hs b/src/System/ArrowVHDL/Circuit/IEEE_STD_LOGIC_1164.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/IEEE_STD_LOGIC_1164.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, RebindableSyntax #-} +module System.ArrowVHDL.Circuit.IEEE_STD_LOGIC_1164 + ( aAnd + , aOr + , aXor + , aNot + ) where + +import System.ArrowVHDL.Circuit.Defaults (aAnd, aOr, aXor, aNot) + + diff --git a/src/System/ArrowVHDL/Circuit/PinTransit.hs b/src/System/ArrowVHDL/Circuit/PinTransit.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/PinTransit.hs @@ -0,0 +1,145 @@ +-- Dieses Modul definiert einen Algebraischen Datentyp der im Codegenerator zur Generierung des Zielcodes benötigt. Er enthält die % TODO : Referenz +-- Komponenten ID, sowie benannte Ein- und Ausgangspins. + + +module System.ArrowVHDL.Circuit.PinTransit +where + + + + +-- Benötigt werden Modul-Definitionen aus \hsSource{Circuit}. + + +import System.ArrowVHDL.Circuit.Descriptor + + +-- \subsection{Datenstruktur} +-- Zunächst werden Typaliasse angelegt, welche die verwendeten Datentypen nach ihrer Aufgabe benennen. + + +type NamedPin = (PinID, String) +type InNames = [NamedPin] +type OutNames = [NamedPin] + +type NamedComp = (CompID, (InNames, OutNames)) + + + +-- \subsection{Funktionen} +-- Um die interne Datenstruktur des Algebraischen Datentypes bedienen zu können, werden folgende Funktionen definiert + +-- generateNamedComps % \\ Eine Funktion die aus einem CircuitDescriptor die Benamte Komponentenliste erstellt +-- getInPinNames % \\ Eine Funktion die eine In-PinID / Namen's Liste aus der NamedComp Liste erzeugt +-- getOutPinNames % \\ Eine Funktion die eine Out-PinID / Namen's Liste aus der NamedComp Liste erzeugt +-- getInPinName % \\ Eien weitere Funktion die ein InPinID/Namens Paar aus der NamedComp Liste und aus einer PinID erstellt +-- getOutPinName % \\ Eien weitere Funktion die ein OutPinID/Namens Paar aus der NamedComp Liste und aus einer PinID erstellt + + +-- Die Funktion \hsSource{generateNamedComps} erzeugt die benannten Komponenten Liste. Hier werden nur die Pins benannt. Ein Pin kann immer von +-- zwei Seiten aus gesehen werden. Es gibt \begriff{externe} Pins, also Pins, die an die von außen ein Draht angeschlossen werden kann. Diese +-- werden unter dem namen \hsSource{generateSuperNames} zusammengefasst. Daneben existieren auch \begriff{interne} Pins, die man hinter dem +-- Namen \hsSource{generateSubNames} findet. Diese Unterscheidung muss getroffen werden, da externe Pins mit den Präfixen \hsSource{nameExI} +-- und \hsSource{nameExO} versehen werden. Interne Pins werden mit \hsSource{nameInI} sowie \hsSource{NameInO} benamt. +-- \hsSource{generateSuperNames} wird auf den übergebenen \hsSource{CircuitDescriptor} angewandt, die Funktion \hsSource{generateSubNames} +-- hingegen auf alle dem \hsSource{CircuitDescriptor} untergeordneten \hsSource{CircuitDescriptor}en. + + +generateNamedComps :: CircuitDescriptor -> [NamedComp] +generateNamedComps g = generateSuperNames g : (map generateSubNames $ nodes g) + where generateSuperNames g = ( (nodeId.nodeDesc) g + , ( namePins (sinks.nodeDesc) nameExI g + , namePins (sources.nodeDesc) nameExO g + ) + ) + generateSubNames g = ( (nodeId.nodeDesc) g + , ( namePins (sinks.nodeDesc) nameInI g + , namePins (sources.nodeDesc) nameInO g + ) + ) + + + + +-- Die beiden Funktionen \hsSource{getNamedInPins} sowie \hsSource{getInPinNames} holen jeweils aus einer Liste von \hsSource{NamedComp} und +-- einer \hsSource{CompID} den passenden Datensatz heraus. Hierbei unterscheiden sie sich lediglich im Rückgabetyp voneinander. So liefert +-- \hsSource{getNamedInPins} die \hsSource{InNames}, also eine Liste benannter Pins, zurück. \hsSource{getInPinNames} liefert nur eine Liste +-- der Namen. + + + -- TODO: is fst the right function to get the in-names ??? + +getNamedInPins :: [NamedComp] -> CompID -> InNames +getNamedInPins = getPinNames fst + +getInPinNames :: [NamedComp] -> CompID -> [String] +getInPinNames cname cid = map snd $ getNamedInPins cname cid + + + + +-- Die beiden nächsten Funktionen, \hsSource{getNamedOutPins} sowie \hsSource{getOutPinNames} verhalten sich analog zu den beiden +-- \begriff{InPin} varianten, mit dem Unterschied, dass diese beiden Funktionen sich auf die Ausgabepins beziehen. + + + -- TODO: is snd the right function to get the out-names ??? + +getNamedOutPins :: [NamedComp] -> CompID -> OutNames +getNamedOutPins = getPinNames snd + +getOutPinNames :: [NamedComp] -> CompID -> [String] +getOutPinNames cname cid = map snd $ getNamedOutPins cname cid + + + + +-- Mit der Funktion \hsSource{getPinNames} wird die eigentliche Logik beschrieben, die für das herausfiltern der Pin-Namen notwendig ist. Aus +-- der übergebenen Liste der benannten Komponenten werden all die Komponenten heraus gefiltert, die der ebenfalls übergebenen Komponenten ID +-- entsprechen. Im nächsten Schritt (\hsSource{map snd}) wird die Komponenten ID verworfen. Die übergeben Funktion \hsSource{f} definiert nun, +-- ob das Ergebnis eingehende oder ausgehende Pins sind. Der letzte Schritt entfernt überflüssige Listen-Verschachtelungen. + + +getPinNames :: (([NamedPin], [NamedPin]) -> [NamedPin]) -> [NamedComp] -> CompID -> [(PinID, String)] +getPinNames f cname cid + = concat + $ map f + $ map snd + $ filter (\(x, _) -> x == cid) + $ cname + + + + +-- Die folgenden fünf Funktionen arbeiten analog zu den vorhergehenden fünf. Sie unterscheiden sich darin, dass sie einen weiteren Parameter +-- erwarten, ein \hsSource{PinID}. Dieser Parameter schränkt die Ergebnismenge auf exakt ein Ergebnis ein, sie liefern also einen benannten +-- Pin. + +getNamedInPin :: [NamedComp] -> CompID -> PinID -> NamedPin +getNamedInPin = getPinName getNamedInPins + +getNamedOutPin :: [NamedComp] -> CompID -> PinID -> NamedPin +getNamedOutPin = getPinName getNamedOutPins + +getInPinName :: [NamedComp] -> CompID -> PinID -> String +getInPinName cname cid pid = snd $ getNamedInPin cname cid pid + +getOutPinName :: [NamedComp] -> CompID -> PinID -> String +getOutPinName cname cid pid = snd $ getNamedOutPin cname cid pid + +getPinName :: ([NamedComp] -> CompID -> [NamedPin]) -> [NamedComp] -> CompID -> PinID -> NamedPin +getPinName f cname cid pid + = head + $ filter (\(x, _) -> x == pid) + $ f cname cid + + + + +-- Die letzte Funktion in diesem Modul erzeugt aus einem \hsSource{CircuitDescriptor} und einem Präfix eine Liste benannter Pins. Diese +-- Funktion wird in \hsSource{generateNamedComps} verwendet, um interne und externe Pins mit Namen zu versehen. Je nach übergebenen +-- \hsSource{f} produziert \hsSource{namePins} benannte interne oder benannte externe Pinlisten. + +namePins :: (CircuitDescriptor -> Pins) -> String -> CircuitDescriptor -> [NamedPin] +namePins f pre g + = map (\x -> (x, pre ++ (show x))) $ f g + diff --git a/src/System/ArrowVHDL/Circuit/Sensors.hs b/src/System/ArrowVHDL/Circuit/Sensors.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Sensors.hs @@ -0,0 +1,149 @@ +-- Das Modul \hsSource{Circuit.Sensors} enthält eine Reihe von Funktionen, die bestimmte Werte aus übergebenen Daten herauslesen. + + +module System.ArrowVHDL.Circuit.Sensors +where + + + +-- Es werden lediglich die Standard Definitionen, sowie die Tests benötigt. + + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Tests + + + +-- \subsection{Schaltungssensoren} +-- Die Funktion \hsSource{allCircuits} holt aus einer Schaltung all die Bausteine heraus, aus denen diese Schaltung aufgebaut ist. Das +-- Ergebnis wird dann als Liste von Bausteinen zurückgegeben. + + +allCircuits :: CircuitDescriptor -> [CircuitDescriptor] +allCircuits sg + = if (length next_sg == 0) then sg : [] + else sg : (concat $ map allCircuits next_sg) + where next_sg = nodes sg + cid = nodeId.nodeDesc $ sg + + + + +-- Mithilfe der Funktion \hsSource{maxCompID} lässt sich die maximale Komponentennummer einer Schaltung anzeigen. + + +maxCompID :: CircuitDescriptor -> CompID +maxCompID sg = (nodeId.nodeDesc $ sg) `max` (foldl max 0 $ map maxCompID (nodes sg)) + + + + +-- Mit der Funktion \hsSource{getComp} lässt sich ein definierter Baustein aus einer Schaltung auslesen. Identifiziert wird der auszulesende +-- Bausteine über seine Komponentennummer. \hsSource{getComp} ist hier die Funktion mit Fehlerbehandlung, die Logik selber steckt in +-- \hsSource{getComp'}. + + +getComp :: CircuitDescriptor -> CompID -> CircuitDescriptor +getComp g cid = if length output == 1 + then head output + else error "getComp: there is no such circuit" + where output = getComp' g cid + +getComp' :: CircuitDescriptor -> CompID -> [CircuitDescriptor] +getComp' g cid + | (nodeId.nodeDesc $ g) == cid + = [g] + | otherwise + = concat $ map (flip getComp' cid) (nodes g) + + + + +-- Um den übergeordneten Schaltkreis eines Bausteins zu erhalten, kann man sich der Funktion \hsSource{superNode} bedienen. Diese Funktion +-- erwartet eine Schaltung sowie eine Komponentennummer. Im Falle das es eine SuperNode \footnote{also eine Schaltung, die mindestens aus der +-- Komponente mit der übergebenen Nummer besteht} gibt, wird diese Zurückgeliefert. Andernfalls wird eine Fehlermeldung ausgegeben. + + +superNode :: CircuitDescriptor -> CompID -> CircuitDescriptor +superNode g cid + = if length output == 1 + then head output + else error "superNode: there is no such supernode" + where output = superNode' g cid + +superNode' :: CircuitDescriptor -> CompID -> [CircuitDescriptor] +superNode' g cid + | g `isSuperNodeOf` cid + = [g] + | otherwise + = concat $ map (flip superNode' cid) $ nodes g + + + + +-- Als atomar werden Schaltungen bezeichnet, die selbst aus keinen weiteren Schaltungen aufgebaut sind. Diese Schaltungen können auch +-- \begriff{Bausteine} genannt werden. Die Funktion \hsSource{nextAtomic} ermöglicht es, aus einer gegebenen Schaltung und einer Kante die +-- nächste Komponente zu ermitteln, die atomar ist. Außerdem wird auch noch der Pin mit angegeben, über welchen diese Komponente angeschlossen +-- ist. + + +nextAtomic :: CircuitDescriptor -> Edge -> (CompID, PinID) +nextAtomic g e + | isToOuter e && (nodeId.nodeDesc $ super) == mainID + = (mainID, snkPin e) + + | isToOuter e + = nextAtomic g $ head $ filter (\x -> sourceInfo x == (Just $ nodeId.nodeDesc $ super, snkPin e)) $ edges supersuper + + | not.isAtomic $ sub + = nextAtomic g $ head $ filter (\x -> (isFromOuter x) && (snkPin e == srcPin x)) $ edges sub + + | isAtomic sub + = (snkComp e, snkPin e) + where mainID = nodeId.nodeDesc $ g + sub = getComp g (snkComp e) + super = superNode g (srcComp e) + supersuper = superNode g (nodeId.nodeDesc $ super) + + + +-- \subsection{Kantensesoren} +-- +-- Mit der Funktion \hsSource{fromCompEdges} können alle Kanten ausgelesen werden, die von einer bestimmten Komponente her kommen. + + +fromCompEdges :: CircuitDescriptor -> CompID -> [Edge] +fromCompEdges g cid + = filter (\x -> (not.isFromOuter $ x) + && (cid == (srcComp x) ) ) $ edges $ superNode g cid + + + + +-- Hilfreich ist auch die Funktion \hsSource{allEdges}, die wie der Name schon vermuten lässt, alle Kanten die innerhalb einer Schaltung +-- verbaut werden, sammelt und als Ergebnisliste zurückgibt. + + +allEdges :: CircuitDescriptor -> [Edge] +allEdges g = edges g ++ (concat $ map allEdges (nodes g)) + + + + +-- \begriff{snk} und \begriff{src} sind Kurzschreibweisen für \begriff{Sink} und \begriff{Source}. Mit den Funktionen \hsSource{snkPin} und +-- \hsSource{srcPin} lassen sich aus einer Kante entweder der Quell- oder der Zielpin auslesen. \hsSource{snkComp} und \hsSource{srcComp} sind +-- dann für die Quell- sowie für die Zielkomponente verantwortlich. + + +snkPin :: Edge -> PinID +snkPin (MkEdge (_, _) (_, pid)) = pid + +srcPin :: Edge -> PinID +srcPin (MkEdge (_, pid) (_, _)) = pid + +snkComp :: Edge -> CompID +snkComp (MkEdge (_, _) (Just cid, _)) = cid + +srcComp :: Edge -> CompID +srcComp (MkEdge (Just cid, _) (_, _)) = cid + diff --git a/src/System/ArrowVHDL/Circuit/Show.hs b/src/System/ArrowVHDL/Circuit/Show.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Show.hs @@ -0,0 +1,41 @@ +-- Dieses Modul stellt die Schnittstelle für die Show-Funktionalität dar. Wird \hsSource{Circuit.Show} in einem anderen Modul eingebunden, so +-- können \hsSource{CircuitDescriptor}en mittels \hsSource{show} angezeigt werden. + +module System.ArrowVHDL.Circuit.Show +where + +-- %% TODO? Btw, for what ever reason, one can't just reload, because this leads to a +-- %% missing object-file error. Exit the ghci and restart it, will do the job. + +import System.ArrowVHDL.Circuit.Descriptor +-- import System.ArrowVHDL.Circuit.Show.Simple +-- import System.ArrowVHDL.Circuit.Show.VHDL +import System.ArrowVHDL.Circuit.Show.DOT +import qualified System.ArrowVHDL.Circuit.Show.Simple as Simple +import qualified System.ArrowVHDL.Circuit.Show.DOT as DOT +import qualified System.ArrowVHDL.Circuit.Show.VHDL as VHDL + +-- An externen Modulen wird hier lediglich die Kerndefinition \hsSource{Circuit.Descriptor} verwendet. Darüber hinaus werden die jeweiligen +-- Anzeigemodule eingebunden. Folgende Formate können als Ausgabeformat gewählt werden: +-- \begin{itemize} +-- \item Mit \begriff{Simple} ist ein Ausgabeformat gemeint, welches sehr kurz und prägnant alle verfügbaren Informationen anzeigt. Dieses +-- Format eignet sich besonders gut, um damit debug-Informationen auszugeben. +-- \item Die \begriff{DOT}-Sprache ist eine Beschreibungssprache, die verwendet wird, um Graphen abzubilden. Es gibt eine ganze Reihe von +-- Werkzeugen \footnote{Für Linux sei hier \begriff{graphviz} genannt}, die dann aus einer \texttt{.dot}-Datei eine Grafik erzeugen können, +-- die den Graphen abbildet. +-- \item Auch das erzeugen von \begriff{VHDL} ist eine Ausgabeform, die über Haskells \hsSource{Show}-Methoden abgebildet wird. +-- \end{itemize} +-- +-- %% To draw a StructGraph it is necessary to make StructGraph an instance of Show and +-- %% therefore the Edge datatypes also needs to be an instance of Show. +-- +-- Um Haskells \hsSource{Show}-Klasse verwenden zu können, muss der Typ \hsSource{CircuitDescriptor} Mitglied der Klasse \hsSource{Show} sein. +-- Da die eigentliche Definition der \hsSource{Show}-Methode in einem Untermodul stattfindet, ist die Instanzdefinition einfach. Es wird +-- lediglich der \hsSource{show}-Methode eine der vorhandenen Methoden zugeordnet. +-- + +instance Show (Edge) where + show = showEdge + +instance Show (CircuitDescriptor) where + show = showCircuit diff --git a/src/System/ArrowVHDL/Circuit/Show/DOT.hs b/src/System/ArrowVHDL/Circuit/Show/DOT.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Show/DOT.hs @@ -0,0 +1,113 @@ +module System.ArrowVHDL.Circuit.Show.DOT +( showCircuit +, showEdge +) +where + +import Data.Maybe ( isJust ) +import Data.List ( nub + , (\\) + ) + +import Prelude hiding ( break ) + +import System.ArrowVHDL.Circuit.Descriptor + +import System.ArrowVHDL.Circuit.PinTransit +import System.ArrowVHDL.Circuit.EdgeTransit + +import System.ArrowVHDL.Circuit.Show.Tools + + +-- This function produces the edge-description as it is required by the +-- dot language... something like this: +-- nodeId3:op0 -nodeId6:ip0 + +showEdge :: Edge -> String +showEdge (MkEdge (Nothing, pid) (Just snk_cid, snk_pid)) + = "xSTART" ++ ':':"op" ++ show pid + ++ " -> " + ++ "nodeId" ++ show snk_cid ++ ':': "ip" ++ show snk_pid +showEdge (MkEdge (Just src_cid, src_pid) (Nothing, pid)) + = "nodeId" ++ show src_cid ++ ':': "op" ++ show src_pid + ++ " -> " + ++ "xEND" ++ ':':"ip" ++ show pid +showEdge e + = "nodeId" ++ show src_cid ++ ':': "op" ++ show src_pid + ++ " -> " + ++ "nodeId" ++ show snk_cid ++ ':': "ip" ++ show snk_pid + where (Just src_cid, src_pid) = sourceInfo e + (Just snk_cid, snk_pid) = sinkInfo e + + +showCircuit :: CircuitDescriptor -> String +showCircuit g + = concat $ map break + [ "" + , "digraph G {" + , dot_config + , dot_outer_nodes g + , dot_components g + , dot_connections g + , "}" + ] + where namedEdges = generateNamedEdges g + namedComps = generateNamedComps g + +dot_config :: String +dot_config + = concat $ map break + [ "" + , "graph [" + , " rankdir = \"LR\"" + , "]" + ] + +dot_outer_nodes :: CircuitDescriptor -> String +dot_outer_nodes g + = concat $ map break + [ "" + , "xSTART [" + , " " ++ dot_outer_label "op" (sinks.nodeDesc $ g) + , " " ++ "shape = \"record\"" + , "]" + , "" + , "xEND [" + , " " ++ dot_outer_label "ip" (sources.nodeDesc $ g) + , " " ++ "shape = \"record\"" + , "]" + ] + +dot_components :: CircuitDescriptor -> String +dot_components g + = concat $ nub $ map f (nodes g) + where f g' = concat $ map break + [ "" + , "nodeId" ++ show (nodeId.nodeDesc $ g') ++ " [" + , " " ++ dot_label (sinks.nodeDesc $ g') (map (\x -> if x == '>' then '-' else x) $ label.nodeDesc $ g') (nodeId.nodeDesc $ g') (sources.nodeDesc $ g') + , " " ++ "shape = \"record\"" + , "]" + ] + +dot_outer_label :: String -> Pins -> String +dot_outer_label s ps + = "label = \" {{ | " + ++ (concat $ map (f s) ps) + ++ "}}\"" + where f :: String -> Int -> String + f s x = "<" ++ s ++ show x ++ "> (" ++ show x ++ ") | " + +dot_label :: Pins -> String -> CompID -> Pins -> String +dot_label ips nme cid ops + = "label = \" {{ | " + ++ (concat $ map (f "ip") ips) + ++ "} | { Name: " ++ nme ++ " | (" ++ show cid ++ ")} | { | " + ++ (concat $ map (f "op") ops) + ++ "}}\"" + where f :: String -> Int -> String + f s x = "<" ++ s ++ show x ++ "> (" ++ show x ++ ") | " + + +dot_connections :: CircuitDescriptor -> String +dot_connections g + = concat $ map (\x -> showEdge x ++ "\n") (edges g) diff --git a/src/System/ArrowVHDL/Circuit/Show/Simple.hs b/src/System/ArrowVHDL/Circuit/Show/Simple.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Show/Simple.hs @@ -0,0 +1,36 @@ +module System.ArrowVHDL.Circuit.Show.Simple +( showCircuit +, showEdge +) +where + +import System.ArrowVHDL.Circuit.Descriptor + +showCircuit :: CircuitDescriptor -> String +showCircuit g = showCircuit' g + ++ "\n" ++ "Area: " ++ (show $ space g) + ++ "\n" ++ "Time: " ++ (show $ cycles g) + +showCircuit' :: CircuitDescriptor -> String +showCircuit' g = "\n" + ++ (show.nodeId.nodeDesc) g + ++ "(" ++ (show.label.nodeDesc) g ++ "): " + ++ (prtInOuts.sinks.nodeDesc) g ++ "] " + ++ (showEdges.edges) g + ++ " [" ++ (prtInOuts.sources.nodeDesc) g + ++ (showNode.nodes) g + where showNode [] = "" + showNode n = concat $ map showCircuit' n + prtInOuts [] = "_" + prtInOuts x = foldl1 (\x y -> x ++ ',':y) $ map show x + + +showEdge :: Edge -> String +showEdge ed = (prtConnection.sourceInfo) ed ++ "->" ++ (prtConnection.sinkInfo) ed + where prtConnection (Just cid, pid) = show (cid, pid) + prtConnection (Nothing, pid) = "(_," ++ show pid ++ ")" + + +showEdges :: [Edge] -> String +showEdges = concat . (map showEdge) + diff --git a/src/System/ArrowVHDL/Circuit/Show/Tools.hs b/src/System/ArrowVHDL/Circuit/Show/Tools.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Show/Tools.hs @@ -0,0 +1,9 @@ +module System.ArrowVHDL.Circuit.Show.Tools +where + + +-- break is a function, that appends a newline character to the +-- end of a string. + +break :: String -> String +break = flip (++) "\n" diff --git a/src/System/ArrowVHDL/Circuit/Show/VHDL.hs b/src/System/ArrowVHDL/Circuit/Show/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Show/VHDL.hs @@ -0,0 +1,249 @@ +module System.ArrowVHDL.Circuit.Show.VHDL +( showCircuit +, showEdge +) +where + +import Data.Maybe ( isJust ) +import Data.List ( nub + , (\\) + ) + +import Prelude hiding ( break ) + +import System.ArrowVHDL.Circuit.Descriptor + +import System.ArrowVHDL.Circuit.PinTransit +import System.ArrowVHDL.Circuit.EdgeTransit +import System.ArrowVHDL.Circuit.Tests + +import System.ArrowVHDL.Circuit.Show.Tools + + +-- The showEdge function is only needed for the Show class. +-- While VHDL-Code is generated, of this function is made no use ... + +showEdge :: Edge -> String +showEdge ed = (prtConnection.sourceInfo) ed ++ "->" ++ (prtConnection.sinkInfo) ed + where prtConnection (Just cid, pid) = show (cid, pid) + prtConnection (Nothing, pid) = "(_," ++ show pid ++ ")" + + +-- In a VHDL-Sorce file, there are two main sections, that we need to specify +-- in order to get working VHDL-Source. +-- +-- The function that starts the show-process is the toVHDL-function. Here we +-- define the basic structure of a VHDL-SourceCode with an header, the +-- entity-definition as well as the component-definition. +-- TODO: Add the signal-definition and the port-map-definitions + +showCircuit :: CircuitDescriptor -> String +showCircuit g + = concat $ map break + [ "" + , vhdl_header + , vhdl_entity g namedComps + , vhdl_architecture g + , vhdl_components g namedComps + , vhdl_signals g namedEdges + , vhdl_portmaps g namedComps namedEdges + ] + where namedEdges = generateNamedEdges g + namedComps = generateNamedComps g + +nameEdges :: String -> CircuitDescriptor -> [([Anchor], String)] +nameEdges pre g + = map (\(i, e) -> (sourceInfo e : sinkInfo e : [], pre ++ show i)) $ zip [0..] relevantEdges + where relevantEdges = filter (\(MkEdge (ci,_) (co,_)) -> isJust ci && isJust co) $ edges g + +nameGraphPins :: CircuitDescriptor -> [(CompID, ([(PinID, String)], [(PinID, String)]))] +nameGraphPins g = nameSuperPins g : (map nameSubPins $ nodes g) + +nameSuperPins :: CircuitDescriptor -> (CompID, ([(PinID, String)], [(PinID, String)])) +nameSuperPins g = (nodeId.nodeDesc $ g, (namedSinks, namedSources)) + where namedSinks = namePins' (sinks.nodeDesc) nameExI g + namedSources = namePins' (sources.nodeDesc) nameExO g + +nameSubPins :: CircuitDescriptor -> (CompID, ([(PinID, String)], [(PinID, String)])) +nameSubPins g = (nodeId.nodeDesc $ g, (namedSinks, namedSources)) + where namedSinks = namePins' (sinks.nodeDesc) nameInI g + namedSources = namePins' (sources.nodeDesc) nameInO g + +namePins' :: (CircuitDescriptor -> Pins) -> String -> CircuitDescriptor -> [(PinID, String)] +namePins' f pre g = map (\x -> (x, pre ++ show x)) $ f g + +-- The VHDL-Header is just some boilerplate-code where library's are imported + +vhdl_header :: String +vhdl_header + = concat $ map break + [ "LIBRARY ieee;" + , "USE ieee.std_logic_1164.all;" + ] + +-- A VHDL-Entity defines an "interface" to a hardware component. It consists of +-- a name and of some port-definitions (like what wires go inside and come back out) + +vhdl_entity :: CircuitDescriptor -> [NamedComp] -> String +vhdl_entity g namedComps + = concat $ map break + [ "ENTITY " ++ (label.nodeDesc) g ++ " IS" + , "PORT (" + , (sepBy "\n" $ map (\x -> x ++ " : IN std_logic;") $ snks) + , (sepBy "\n" $ map (\x -> x ++ " : OUT std_logic ") $ srcs) + , ");" + , "END " ++ (label.nodeDesc) g ++ ";" + ] + where snks = getInPinNames namedComps (nodeId.nodeDesc $ g) + srcs = getOutPinNames namedComps (nodeId.nodeDesc $ g) + +vhdl_architecture :: CircuitDescriptor -> String +vhdl_architecture g + = "ARCHITECTURE " ++ (label.nodeDesc $ g) ++ "Struct OF " ++ (label.nodeDesc $ g) ++ " IS" + + +-- The VHDL-Component definitions describe the basic interface to the components +-- that are used inside this new definition. We therefore pick the components +-- of which these new component consists. We call this components the level 1 +-- components, because we descent only one step down in the graph. + +vhdl_components :: CircuitDescriptor -> [NamedComp] -> String +vhdl_components g namedComps + = concat $ nub $ map f (nodes g) + where f g' = concat $ map break + [ "" + , "COMPONENT " ++ (label.nodeDesc $ g') ++ "Comp" + , "PORT (" + , (sepBy "\n" $ map (\x -> x ++ " : IN std_logic;") $ snks) + , (sepBy "\n" $ map (\x -> x ++ " : OUT std_logic ") $ srcs) + , ");" + , "END COMPONENT " ++ (label.nodeDesc $ g') ++ "Comp;" + ] + where snks = getInPinNames namedComps (nodeId.nodeDesc $ g') + srcs = getOutPinNames namedComps (nodeId.nodeDesc $ g') + + +-- The VHDL-Signals is the list of inner wires, that are used inside the new component. + +vhdl_signals :: CircuitDescriptor -> [([Anchor], String)] -> String +vhdl_signals _ [] = "" +vhdl_signals g namedEdges + = "SIGNAL " ++ sepBy ", " signals ++ ": std_logic;" + where signals = map snd namedEdges + + +vhdl_portmaps :: CircuitDescriptor -> [NamedComp] -> [([Anchor], String)] -> String +vhdl_portmaps g namedComps namedEdges + = concat $ map break + [ "BEGIN" + , concat $ map (vhdl_portmap g namedComps namedEdges) $ nodes g + , "END;" + ] + +vhdl_portmap :: CircuitDescriptor -> [NamedComp] -> [([Anchor], String)] -> CircuitDescriptor -> String +vhdl_portmap superG namedComps namedEdges' g + = concat $ map break + [ (label.nodeDesc $ g) ++ "Inst" ++ (show.nodeId.nodeDesc $ g) ++ ": " ++ (label.nodeDesc $ g) ++ "Comp" + , "PORT MAP (" + ++ (sepBy ", " $ filter ((>0).length) [incoming, signaling, outgoing]) + ++ ");" + ] + where relevantEdges = filter (isFromOrToComp $ nodeId.nodeDesc $ g) $ edges superG + edge2inside = filter (isFromOuter) $ relevantEdges + edge2outside = filter (isToOuter) $ relevantEdges + pin2signal = relevantEdges \\ (edge2outside ++ edge2inside) + incoming = sepBy ", " $ map (genPortMap namedComps namedEdges' (nodeId.nodeDesc $ g)) $ edge2inside + outgoing = sepBy ", " $ map (genPortMap namedComps namedEdges' (nodeId.nodeDesc $ g)) $ edge2outside + signaling = sepBy ", " $ map (genPortMap namedComps namedEdges' (nodeId.nodeDesc $ g)) $ pin2signal + + +genPortMap :: [NamedComp] -> [NamedEdge] -> CompID -> Edge -> String + +-- From the inner component to the outside +-- : PORT MAP (a0 =out0, a1 => out1); +-- +--------+ +-- | pi = [0] - +-- |ci = 0 | +-- | pi = [1] - +-- +--------+ + +genPortMap namedComps _ _ (MkEdge (Just ci, pi) (Nothing, po)) + = pinName ++ " => " ++ outName + where pinName = getOutPinName namedComps ci pi + outName = getOutPinName namedComps superCid po + superCid = fst . head $ namedComps + + +-- From the outside to the inner component +-- : PORT MAP (e0 =in0, e1 => in1); +-- +--------+ +-- -[0] = po | +-- |co = 0 | +-- -[1] = po | +-- +--------+ + +genPortMap namedComps _ _ (MkEdge (Nothing, pi) (Just co, po)) + = pinName ++ " => " ++ incName + where pinName = getInPinName namedComps co po + incName = getInPinName namedComps superCid pi + superCid = fst . head $ namedComps + + +-- From the inner component to an inner signal +-- : PORT MAP (a0 =i0, a0 => i1); +-- +--------+ +--------+ +-- | pi = [0] - -----i0------ -> [0] = po | +-- |ci = 0 | |co = 1 | +-- | pi = [1] - ------i1----- -> [1] = po | +-- +--------+ +--------+ + +genPortMap namedComps namedEdges ownID (MkEdge ie@(Just ci, pi) oe@(Just co, po)) + | ownID == ci = iPinName ++ " => " ++ iSigName + | ownID == co = oPinName ++ " => " ++ oSigName + where iPinName = getOutPinName namedComps ci pi + oPinName = getInPinName namedComps co po + iSigName = getEdgeName namedEdges ie + oSigName = getEdgeName namedEdges oe + + + + +-- In the last genPortMap function there are some irregularities +-- +-- TODO TODO TODO / why is it called iPin when the out-pin is gathered with the (map snd) bevore the concat??? +-- where iPinNames = concat $ map snd $ map snd $ filter (\(cid, _) -cid == ci) $ namedGraphPins +-- +-- TODO TODO TODO / why is it called oPin when the in-pin is gathered with the (map fst) bevore the concat??? +-- oPinNames = concat $ map fst $ map snd $ filter (\(cid, _) -cid == co) $ namedGraphPins +-- +-- iPinName = head $ map snd $ filter (\(pid, _) -pid == pi) $ iPinNames +-- oPinName = head $ map snd $ filter (\(pid, _) -pid == po) $ oPinNames + + +-- The namePins function takes a function that extracts a list of PinIDs out of an StructGraph. +-- (This could be the sinks or the sources functions) +-- It also takes a StructGraph (suprise :)) and a String, that is prepended to the actual PinName. +-- This functions returns a list, where every element is a tuple of the actual named pin (a string) +-- and a part, that identifies the name. + +namePins :: (CircuitDescriptor -> Pins) -> String -> CircuitDescriptor -> [(String, Anchor)] +namePins f pre g + = map (\x -> (pre ++ (show x), (Nothing, x))) $ f g +-- = map (\x -> (pre ++ (show x), (nodeId g, x))) $ f g + + +-- The nameEdges function is pretty similar to the namePins function with some minor differences. +-- First of all, you don't need a function that extracts the edges of a StructGraph. There is +-- only one field in the StructGraph that holds the edges. +-- And also the return-type is a bit simpler, becaus an edge identifies itself, so there is no need +-- to do this once more. + +-- nameEdges :: String -> CircuitDescriptor -> [(String, Edge)] +-- nameEdges pre g +-- = map (\(num, edge) -> (pre ++ (show num), edge)) $ zip [0..] (edges g) + + +sepBy :: String -> [String] -> String +sepBy sep [] = "" +sepBy sep (x:[]) = x +sepBy sep xs = foldl1 (\x y -> x ++ sep ++ y) xs diff --git a/src/System/ArrowVHDL/Circuit/ShowType.hs b/src/System/ArrowVHDL/Circuit/ShowType.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/ShowType.hs @@ -0,0 +1,10 @@ +-- Das Modul \hsSource{Circuit.ShowType} ist ein strukturelles Modul nach dem Fassaden-Entwurfsmuster. + +module System.ArrowVHDL.Circuit.ShowType (ShowType(..)) +where + + +-- Folgenden Module werden benötigt, um die Instanzen definieren zu können: + +import System.ArrowVHDL.Circuit.ShowType.Class (ShowType(..)) +import System.ArrowVHDL.Circuit.ShowType.Instance diff --git a/src/System/ArrowVHDL/Circuit/ShowType/Class.hs b/src/System/ArrowVHDL/Circuit/ShowType/Class.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/ShowType/Class.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + +-- Das Modul \hsSource{Circuit.ShowType.Class} beschreibt, wie die Arrow-Klasse zu implementieren sind um damit später Schaltkreise +-- beschreiben, bearbeiten oder benutzen zu können. + +module System.ArrowVHDL.Circuit.ShowType.Class +where + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: + +import Prelude hiding (id, (.)) +import qualified Prelude as Pr + +import Control.Category + +import System.ArrowVHDL.Circuit.Descriptor + + +-- Zunächst einmal müssen die Klassen definiert werden. Diese Vorgaben müssen von allen Instanzdefinitionen befolgt werden. + +-- Die \hsSource{ShowType}-Klasse wird benötigt, um zur Laufzeit Typinformationen in den \hsSource{Arrow} zu bekommen. Dies wird immer dann +-- ausgenutzt, wenn mittels \hsSource{arr} eine Funktion in einen Arrow geliftet wird. Wie man später in der \hsSource{Arrow}-Klassen +-- Definition erkennen kann, ist \hsSource{arr} nur für Funktionen definiert, die auch in \hsSource{ShowType} sind. + +class ShowType b c where + showType :: (b -> c) -> CircuitDescriptor diff --git a/src/System/ArrowVHDL/Circuit/ShowType/Instance.hs b/src/System/ArrowVHDL/Circuit/ShowType/Instance.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/ShowType/Instance.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + + +-- Das Modul \hsSource{Circuit.ShowType.Instance} beschreibt, wie die Arrow-Klasse zu implementieren sind um damit später Schaltkreise +-- beschreiben, bearbeiten oder benutzen zu können. + +module System.ArrowVHDL.Circuit.ShowType.Instance +where + + +-- Folgenden Module werden benötigt, um die Instanzen definieren zu können: + +import System.ArrowVHDL.Circuit.ShowType.Class + +import Prelude hiding (id, (.)) +import qualified Prelude as Pr + +import Control.Category + +import System.ArrowVHDL.Circuit.Graphs +import System.ArrowVHDL.Circuit.Descriptor + +-- Showtype wird hier für bestimmte Tupel-Typen beschrieben. Einzig die Tupel-Information ist das, was mittels Showtype in Pin-Informationen +-- übersetzt wird. + + +-- Die \hsSource{ShowType}-Instanz definiert die verschiedenen Typenvarianten, welche abbildbar sind. + +-- Mit dem Typ \hsSource{(b, c) -> (c, b)} stellt die folgende Variante eine dar, in der die Ein- und Ausgänge miteinander vertauscht werden. + +instance ShowType (b, c) (c, b) where + showType _ + = emptyCircuit { nodeDesc = MkNode + { label = "|b,c>c,b|" + , nodeId = 0 + , sinks = mkPins 2 + , sources = mkPins 2 + } + } + where nd = nodeDesc emptyCircuit + + +-- Diese Variante mit dem Typ \hsSource{b -> (b, b)} beschreibt den Fall, in dem ein Eingang verdoppelt wird. + +instance ShowType b (b, b) where + showType _ + = emptyCircuit { nodeDesc = MkNode + { label = "|b>b,b|" + , nodeId = 0 + , sinks = mkPins 1 + , sources = mkPins 2 + } + } + where nd = nodeDesc emptyCircuit + + +-- Mit dem Typ \hsSource{(b, b) -> b} wir dann der Fall abgebildet, der zwei Eingänge auf einen zusammenfasst. + +instance ShowType (b, b) b where + showType _ + = emptyCircuit { nodeDesc = MkNode + { label = "|b,b>b|" + , nodeId = 0 + , sinks = mkPins 2 + , sources = mkPins 1 + } + } + where nd = nodeDesc emptyCircuit + +-- instance ShowType (b, c) (b', c') where +-- showType _ = emptyCircuit { label = "b,c>b',c'" +-- , sinks = mkPins 1 +-- , sources = mkPins 1 +-- } +-- +-- instance ShowType b b where +-- showType _ = emptyCircuit { label = "|b>b|" +-- , sinks = mkPins 1 +-- , sources = mkPins 1 +-- } +-- +-- instance ShowType (b -> (c, d)) where +-- showType _ = emptyCircuit { label = "b>c,d" +-- , sinks = mkPins 1 +-- , sources = mkPins 1 +-- } +-- +-- instance ShowType ((b, c) -> d) where +-- showType _ = emptyCircuit { label = "b,c>d" +-- , sinks = mkPins 1 +-- , sources = mkPins 1 +-- } + +-- Letztlich bleibt noch der allgemeinste Fall der Möglich ist. Diese Varianten ist somit auch eine \begriff{CatchAll} Variante. + +instance ShowType b c where + showType _ + = emptyCircuit { nodeDesc = MkNode + { label = "|b>c|" + , nodeId = 0 + , sinks = mkPins 1 + , sources = mkPins 1 + } + } + where nd = nodeDesc emptyCircuit diff --git a/src/System/ArrowVHDL/Circuit/Splice.hs b/src/System/ArrowVHDL/Circuit/Splice.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Splice.hs @@ -0,0 +1,226 @@ +-- Das Module \hsSource{Circuit.Splice} bietet nach außen hin nur eine +-- Funktion an, nämlich \hsSource{splice}. Diese Funktion führt zwei +-- Schaltungen zu einer neuen zusammen. Dabei ist noch nicht +-- festgelegt, wie dieses Zusammenführen tatsächlich aussieht. + +module System.ArrowVHDL.Circuit.Splice +where + +-- Verwendet werden die Standard-Definitionen, sowie eine Sensor und +-- einer Worker Funktion. + + +import Data.List (nub) + +import System.ArrowVHDL.Circuit.Graphs + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Workers (alterCompIDs) +import System.ArrowVHDL.Circuit.Sensors (maxCompID) + + +-- Auch wenn hier tatsächlich zwei Funktionen stehen wird +-- \hsSource{splice} doch als eine Einheit +-- angesehen. \hsSource{splice'} enthält die Funktionalität, +-- \hsSource{splice} ist der öffentliche Bezeichner, der obendrein +-- noch eine grundlegende Fehlerprüfung macht. + +-- \hsSource{splice} wird eine \hsSource{rewire} Funktion +-- übergeben. Diese Funktion enthält die Logik, nach der die +-- ``Verdrahtung'' der beiden Schaltkreise erfolgen wird. Hier ist es +-- dann möglich beispielsweise sequentiell oder parallel zu +-- verdrahten. Außerdem erwartet \hsSource{splice} noch zwei +-- Schaltungen, die zusammengeführt werden sollen. Diese beiden werden +-- dann auf die gewählte Art miteinander verbunden. Die übrigen +-- ``Drähte'' werden nach außen geführt, ein neuer Name wird erzeugt +-- und dieser neue Schaltkreis wird dann zurückgegeben. + +splice :: ((CircuitDescriptor -> CircuitDescriptor -> ([Edge], (Pins, Pins))), String) + -> CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +splice _ sg NoDescriptor = sg +splice _ NoDescriptor sg = sg +splice (rewire, s) cd_f cd_g = splice' (rewire, s) cd_f cd_g + + +splice' :: ((CircuitDescriptor -> CircuitDescriptor -> ([Edge], (Pins, Pins))), String) + -> CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +splice' (rewire, s) cd_f cd_g + = MkCombinatorial + { nodeDesc = MkNode + { label = (label.nodeDesc $ cd_f') ++ s ++ (label.nodeDesc $ cd_g') + , nodeId = 0 + , sinks = srcs + , sources = snks + } + , nodes = cd_f': cd_g' : [] + , edges = es + , cycles = (cycles cd_f) + (cycles cd_g) + , space = (space cd_f) + (space cd_g) + } + where cd_f' = alterCompIDs 1 cd_f + cd_g' = alterCompIDs (maxCompID cd_f' +1) cd_g + (es, (srcs, snks)) = rewire cd_f' cd_g' + + + +-- \subsection{Verdrahtungsvarianten} Die Funktion \hsSource{splice} +-- aus dem Modul \ref{mod:Circuit.Splice} verwendet für das +-- ``verdrahten'' eine der folgenden +-- \hsSource{rewire}-Funktionen. Daneben wird noch eine Zeichenkette +-- zugeordnet, um später debug-Ausgaben erzeugen zu können. + +-- Die \hsSource{connect} Funktion verbindet zwei Schaltkreise zu +-- einem neuen. Hierbei wird sequentiell verbunden, als Zeichenkette +-- wird der selbe Operator angegeben, wie er auch aus der +-- \hsSource{Arrow}-Schreibweise schon bekannt ist. + +connect :: CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +connect = splice (seqRewire, ">>>") + + +-- Neben dem sequentiellen verbinden lassen sich Schaltkreise auch +-- parallel verbinden. Dies ist mit der Funktion \hsSource{combine} +-- möglich. Als Zeichenkette wird auch hier das aus der +-- \hsSource{Arrow}-Schreibweise bekannte Operator-Symbol verwendet. +-- %%% TODO : combine = frame??? + +combine :: CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +combine = splice (parRewire, "&&&") + + +-- Eine Variante der \hsSource{combine} Funktion ist die Funktion +-- \hsSource{dupCombine}. Hier werden die Eingänge zunächst dupliziert +-- und dann parallel weiter verbunden. + +dupCombine :: CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +dupCombine = splice (dupParRewire, ">2>") + + +-- Um eine Verzögerung in Hardware zu realisieren ist es notwendig die +-- Daten zu speichern. Dies wird über ein Register erreicht. Nach der +-- gewünschten Anzahl von Zyklen, kann dann das Datum aus dem Register +-- wieder ausgelesen werden, und in der Schaltung weiter verwendet +-- werden. Die Funktion %%%%%%%%%%%%%%%%%%% %%% TODO : Schaltwerke + +delayByRegister :: CircuitDescriptor -> CircuitDescriptor +delayByRegister cd@(MkCombinatorial nd _ _ _ _) + = MkComposite (cd : reg : []) + where reg = mkRegister nd + + + +-- Möchte man einen \begriff{Loop} erstellen, so wird dieser durch ein +-- Register geführt, dass eine Verzögerung um einen Takt +-- ermöglicht. Die Funktion, die ein Bauteil um eine Schleife mit +-- Register erweitert, nennt sich \hsSource{registerloopRewire}. Diese +-- Funktion lässt sich mittels \hsSource{splice} zu der nach Außen +-- verwendeten \hsSource{loopWithRegister} Funktion umbauen. + + +loopWithRegister :: CircuitDescriptor -> CircuitDescriptor +loopWithRegister cd + = MkLoop + { nodeDesc = MkNode + { label = "loop(" ++ (label.nodeDesc $ cd) ++ ")" + , nodeId = 0 + , sinks = srcs + , sources = snks + } + , nodes = [alterCompIDs 1 cd] + , edges = es + , space = space cd + } + where (es, (srcs, snks)) = registerLoopRewire cd + + +-- Unter den \hsSource{rewire}-Funktionen sind Funktionen zu +-- verstehen, die eine Vorstufe für die eigentliche Verbindung (das +-- \begriff{splicen}) darstellen. Zwei Schaltkreise werden jeweils in +-- eine Zwischendarstellung überführt. Die Zwischendarstellung besteht +-- aus einer Liste von neuen Kanten (\hsSource{[Edge]}), zusammen mit +-- den überbleibenden Ein- und Ausgangspins. +-- +-- Alle \hsSource{rewire}-Funktionen nutzen eine Funktion, nämlich +-- \hsSource{wire}. Das verbinden von Drähten mit Komponenten ist, +-- unabhängig davon ob sequentiell oder parallel verbunden werden +-- soll, immer gleich. Eingehende Parameter zu \hsSource{wire} sind +-- die beiden Komponenten Nummern, sowie die Pin-Listen. Auch diese +-- Funktion erzeugt die schon beschriebene Zwischendarstellung. + +wire :: Maybe CompID -> Maybe CompID -> Pins -> Pins -> ([Edge], (Pins, Pins)) +wire cid_l cid_r pins_l pins_r + = (edges, (drop cnt pins_l, drop cnt pins_r)) + where points_l = map ((,) (cid_l)) pins_l + points_r = map ((,) (cid_r)) pins_r + edges = map (uncurry MkEdge) $ zip points_l points_r + cnt = length edges + + +-- \hsSource{wire_} ist ein Synonym für \hsSource{fst . wire}. + +wire_ :: Maybe CompID -> Maybe CompID -> Pins -> Pins -> [Edge] +wire_ cid_l cid_r pins_l pins_r = fst $ wire cid_l cid_r pins_l pins_r + + +-- Bei der Funktion \hsSource{seqRewire} werden die Verbindungen +-- sequentiell erstellt; übrige Ein oder Ausgänge werden zu den gesamt +-- Ein und Ausgängen hinzugefügt. + +seqRewire :: CircuitDescriptor -> CircuitDescriptor -> ([Edge], (Pins, Pins)) +seqRewire sg_l sg_r + = ( fromOuterToL ++ fromOuterToR ++ edgs ++ fromRToOuter ++ fromLToOuter + , (super_srcs, super_snks) + ) + where (edgs, (srcs_l', snks_r')) = wire (Just $ nodeId.nodeDesc $ sg_l) (Just $ nodeId.nodeDesc $ sg_r) (sources.nodeDesc $ sg_l) (sinks.nodeDesc $ sg_r) + super_srcs = [0..(length.sinks.nodeDesc $ sg_l) + length snks_r' -1] + super_snks = [0..(length.sources.nodeDesc $ sg_r) + length srcs_l' -1] + ( fromOuterToL, (super_srcs', _)) = wire Nothing (Just $ nodeId.nodeDesc $ sg_l) super_srcs (sinks.nodeDesc $ sg_l) + ( fromOuterToR, (_ , _)) = wire Nothing (Just $ nodeId.nodeDesc $ sg_r) super_srcs' (drop (length fromOuterToL) $ sinks.nodeDesc $ sg_r) + ( fromRToOuter, (_, super_snks')) = wire (Just $ nodeId.nodeDesc $ sg_r) Nothing (sources.nodeDesc $ sg_r) super_snks + ( fromLToOuter, (_, _)) = wire (Just $ nodeId.nodeDesc $ sg_l) Nothing (drop (length fromRToOuter) $ sources.nodeDesc $ sg_l) super_snks' + + +-- Bei der \hsSource{parRewire} Funktion werden beide Bausteine +-- ``übereinander'' angeordnet. Die Eingänge beider Komponenten, sowie +-- deren Ausgänge werden parallel geschaltet. + +parRewire :: CircuitDescriptor -> CircuitDescriptor -> ([Edge], (Pins, Pins)) +parRewire sg_u sg_d + = ( goingIn_edges ++ goingOut_edges + , (super_srcs, super_snks) + ) + where super_srcs = [0..(length $ (sinks.nodeDesc $ sg_u) ++ (sinks.nodeDesc $ sg_d)) -1] + super_snks = [0..(length $ (sources.nodeDesc $ sg_u) ++ (sources.nodeDesc $ sg_d)) -1] + goingIn_edges = (wire_ Nothing (Just $ nodeId.nodeDesc $ sg_u) (super_srcs) (sinks.nodeDesc $ sg_u)) + ++ (wire_ Nothing (Just $ nodeId.nodeDesc $ sg_d) (drop (length.sinks.nodeDesc $ sg_u) super_srcs) (sinks.nodeDesc $ sg_d)) + goingOut_edges = (wire_ (Just $ nodeId.nodeDesc $ sg_u) Nothing (sources.nodeDesc $ sg_u) (super_snks)) + ++ (wire_ (Just $ nodeId.nodeDesc $ sg_d) Nothing (sources.nodeDesc $ sg_d) (drop (length.sources.nodeDesc $ sg_u) super_snks)) + + +-- Die Funktion \hsSource{dupParRewire} funktioniert dabei analog zur +-- Funktion \hsSource{parRewire}. Lediglich die Eingänge werden +-- zunächst dupliziert und dann auf beide Komponenten geschaltet. + +dupParRewire :: CircuitDescriptor -> CircuitDescriptor -> ([Edge], (Pins, Pins)) +dupParRewire sg_u sg_d + = ( goingIn_edges ++ goingOut_edges + , (super_srcs, super_snks) + ) + where super_srcs = [0..(length.sinks.nodeDesc $ sg_u) -1] + super_snks = [0..(length $ (sources.nodeDesc $ sg_u) ++ (sources.nodeDesc $ sg_d)) -1] + goingIn_edges = (wire_ Nothing (Just $ nodeId.nodeDesc $ sg_u) super_srcs (sinks.nodeDesc $ sg_u)) + ++ (wire_ Nothing (Just $ nodeId.nodeDesc $ sg_d) super_srcs (sinks.nodeDesc $ sg_d)) + goingOut_edges = (wire_ (Just $ nodeId.nodeDesc $ sg_u) Nothing (sources.nodeDesc $ sg_u) (super_snks)) + ++ (wire_ (Just $ nodeId.nodeDesc $ sg_d) Nothing (sources.nodeDesc $ sg_d) (drop (length.sources.nodeDesc $ sg_u) super_snks)) + + + +registerLoopRewire :: CircuitDescriptor -> ([Edge], (Pins, Pins)) +registerLoopRewire cd + = (es, (srcs, snks)) + where reg = mkRegister $ nodeDesc emptyCircuit + (es1, (srcs1, snks1)) = seqRewire cd reg + (es2, (srcs2, snks2)) = seqRewire reg cd + es = es1 ++ es2 + srcs = nub $ filter (flip elem srcs2) srcs1 ++ filter (flip elem srcs1) srcs2 + snks = nub $ filter (flip elem snks2) snks1 ++ filter (flip elem snks1) snks2 diff --git a/src/System/ArrowVHDL/Circuit/Stream.hs b/src/System/ArrowVHDL/Circuit/Stream.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Stream.hs @@ -0,0 +1,12 @@ +-- Das Modul \hsSource{Circuit.Stream} stellt ein Wrapper-Modul nach dem Fassaden Entwurfsmuster dar. + +module System.ArrowVHDL.Circuit.Stream + ( Stream(..) + ) +where + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: + +import System.ArrowVHDL.Circuit.Stream.Datatype +import System.ArrowVHDL.Circuit.Stream.Instance diff --git a/src/System/ArrowVHDL/Circuit/Stream/Datatype.hs b/src/System/ArrowVHDL/Circuit/Stream/Datatype.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Stream/Datatype.hs @@ -0,0 +1,18 @@ +-- Das Modul \hsSource{Circuit.Stream.Datatype} beschreibt, was ein Stream-Datentyp ist. + +module System.ArrowVHDL.Circuit.Stream.Datatype +where + + +-- In Schaltkreisen sind Schleifen nicht über den normalen \hsSource{ArrowLoop} Ansatz realisierbar. Das Problem liegt darin, dass zwischen +-- zwei Berechnungen keine Verzögerung stattfindet. Wollte man das erreichen, so benötigt man mindestens \begriff{Register}, die einen +-- Taktzyklus verzögern. Damit ist dann festgelegt, dass im Grunde Schleifen in Hardware nur dann Sinn ergeben, wenn ein kontinuierlicher +-- Datenstrom verarbeitet werden kann. + +-- Auch für andere Ansätze wird eine \hsSource{Stream}-Arrow notwendig. Dies kann beispielsweise der Fall sein falls Zwischenergebnisse +-- Innerhalb des Schaltkreises ermittelt werden sollen. + +-- Zunächst wird der Datentyp definiert. \hsSource{Stream} hat einen Typkonstruktor \hsSource{SF} und besteht aus einer Funktion, welche aus +-- einer Liste von b's (\hsSource{[b]}) eine Liste von c's \hsSource{[c]}) erzeugt. + +newtype Stream b c = SF { runStream :: ([b] -> [c]) } diff --git a/src/System/ArrowVHDL/Circuit/Stream/Instance.hs b/src/System/ArrowVHDL/Circuit/Stream/Instance.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Stream/Instance.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Arrows, + OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + NoMonomorphismRestriction, + MultiParamTypeClasses, + FlexibleInstances, + RebindableSyntax #-} + +-- Das Modul \hsSource{Circuit.Stream.Instance} beschreibt, wie die Arrow-Klasse zu implementieren sind um damit später Schaltkreise beschreiben, +-- bearbeiten oder benutzen zu können. + +module System.ArrowVHDL.Circuit.Stream.Instance +where + + +-- Folgenden Module werden benötigt, um die Arrows definieren zu können: + +import Prelude hiding (id, (.)) +import qualified Prelude as Pr + +import Control.Category + +import System.ArrowVHDL.Circuit.Arrow + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Graphs +import System.ArrowVHDL.Circuit.Workers (flatten) + +import System.ArrowVHDL.Circuit.Stream.Datatype + + + +-- Im nächsten Schritt wird \hsSource{Stream} dann zu einer Kategorie ernannt, indem die \hsSource{Category}-Typklasse für \hsSource{Stream} +-- implementiert wird. Erst wenn \hsSource{Stream} eine Kategorie ist, lässt sich \hsSource{Stream} in einen Arrow befördern. + +instance Category Stream where + id + = SF (id) + + (SF f) . (SF g) + = SF (f . g) + + +-- Nachdem \hsSource{Stream} eine Kategorie ist, kann \hsSource{Stream} als Arrow implementiert werden. Ähnlich wie bei der Implementierung der +-- Arrow Instanz von \hsSource{Grid} ist es auch bei \hsSource{Stream} notwendig, alle Funktionsbeschreibungen anzugeben. Die abgeleiteten +-- Funktionen der minimal Definition, reichen nicht aus. + +instance Arrow Stream where + arr f + = SF $ map f -- ?? (SF . map) f ?? + + first (SF f) + = SF $ (uncurry zip) . (\(bs, cs) -> (f bs, cs)) . unzip + + second (SF g) + = SF $ (uncurry zip) . (\(bs, cs) -> (bs, g cs)) . unzip + + (SF f) *** (SF g) + = SF $ (uncurry zip) . (\(bs, cs) -> (f bs, g cs)) . unzip + + +-- Da \hsSource{Stream} ein Arrow ist und Kontinuierliche Datenströme für das Looping notwendig sind, kann für \hsSource{Stream} auch die +-- \hsSource{ArrowLoop} Instanz angegeben werden. + +instance ArrowLoop Stream where + loop (SF f) + = SF $ (\bs -> + let (cs, ds) = unzip . f $ zip bs (stream ds) + in cs + ) + where stream ~(x:xs) = x:stream xs + + +-- Mit der \hsSource{Stream} Instanz von \hsSource{ArrowLoop} ist es nun auch möglich, die \hsSource{ArrowCircuit} Instanz zu implementieren. +-- Diese ist eine direkte Umsetzung des \hsSource{delay}'s auf die Listenfunktionalität. + +instance ArrowCircuit Stream where + delay x = SF (x:) diff --git a/src/System/ArrowVHDL/Circuit/Tests.hs b/src/System/ArrowVHDL/Circuit/Tests.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Tests.hs @@ -0,0 +1,95 @@ +-- Dieses Modul beschreibt eine Reihe von Funktionen zum prüfen von Eigenschaften. Diese Funktionen haben eine Gemeinsamkeit, nämlich dass sie +-- letztlich immer einen \hsSource{Bool}-Wert erzeugen. + + +module System.ArrowVHDL.Circuit.Tests +where + +-- Lediglich das Modul \hsSource{Circuit.Descriptor} wird benötigt + + +import System.ArrowVHDL.Circuit.Descriptor + + +-- Die Funktion \hsSource{isFromOrToComp} ermittelt ob eine übergebene Kante eine Verbindung zu einer Komponente, die über ihre Komponenten ID +-- identifiziert wird, darstellt. + +isFromOrToComp :: CompID -> Edge -> Bool +isFromOrToComp cid (MkEdge (Nothing, pi) (Just co, po)) = cid == co +isFromOrToComp cid (MkEdge (Just ci, pi) (Nothing, po)) = cid == ci +isFromOrToComp cid (MkEdge (Just ci, pi) (Just co, po)) = cid == co + + +-- Jeder Schaltkreis besitzt eine innere Verschaltung und daneben eine Verbindung zur Außenwelt. Eine Kante kann von ``Außen'' her kommen, oder +-- nach ``Außen'' gehen. Genau diese Kanten sind die Pins eines tatsächlichen Chips. + + +-- Mit \hsSource{isToOuter} wird getestet, ob es sich um eine abgehende Kante, also einen ``outgoing''-Pin handelt. + +isToOuter :: Edge -> Bool +isToOuter (MkEdge (_, _) (Nothing, _)) = True +isToOuter _ = False + + +-- \par Das Pendant zu abgehenden Kanten sind eingehende Kanten. Diese werden auch als Inputs bezeichnet. \hsSource{isFromOuter} testet, ob +-- eine Kante eingehend ist. + +isFromOuter :: Edge -> Bool +isFromOuter (MkEdge (Nothing, _) (_, _)) = True +isFromOuter _ = False + + + + +-- Mit der Funktion \hsSource{hasLabel} wird überprüft, ob ein Schaltkreis den übergebenen Namen trägt. + +hasLabel :: String -> CircuitDescriptor -> Bool +hasLabel s + = ((== s).label.nodeDesc) + + +-- \hsSource{isAtomic} überprüft, ob ein Baustein atomar ist, also ob er aus weiteren Bausteinen zusammengesetzt ist, oder nicht. + +isAtomic :: CircuitDescriptor -> Bool +isAtomic g + = if (length (nodes g) == 0) then True else False + + +-- Die Funktion \hsSource{isSuperNodeOf} testet, ob eine Komponente eine bestimmte andere Komponente, identifiziert durch ihre Komponenten ID, +-- enthält. + +isSuperNodeOf :: CircuitDescriptor -> CompID -> Bool +isSuperNodeOf g cid + = if length (filter (== cid) subNodes) > 0 + then True + else False + where subNodes = map (nodeId.nodeDesc) $ nodes g + + +-- Mit der Funktion \hsSource{isGenerated} lässt sich herausfinden, ob einen Komponente eine vom Entwickler entwickelte Komponente ist, oder ob +-- diese Komponente automatisch vom System erzeugt wurde. + +isGenerated :: CircuitDescriptor -> Bool +isGenerated s = ((== '|').head.label.nodeDesc) s && ((== '|').head.reverse.label.nodeDesc) s + + + +-- %%% TODO : isID ist nur eine debugging funktion und muss rausgenommen werden + +isID :: CircuitDescriptor -> Bool +isID = hasLabel "-ID-" + +-- In einem weiteren Test wird die Art der Schaltung überprüft. Handelt es sich bei dem vorliegenden \hsSource{CircuitDescriptor} um einen +-- Kombinatorischen Schaltkreis, um ein Register oder um eine Schleife? + +isCombinatorial :: CircuitDescriptor -> Bool +isCombinatorial (MkCombinatorial _ _ _ _ _) = True +isCombinatorial otherwise = False + +isRegister :: CircuitDescriptor -> Bool +isRegister (MkRegister _ _) = True +isRegister otherwise = False + +isLoop :: CircuitDescriptor -> Bool +isLoop (MkLoop _ _ _ _) = True +isLoop otherwise = False diff --git a/src/System/ArrowVHDL/Circuit/Tools.hs b/src/System/ArrowVHDL/Circuit/Tools.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Tools.hs @@ -0,0 +1,149 @@ +-- Dieses Modul stellt Funktionen zur Verfügung die beim erstellen von Beispielen nützlich sind. + +module System.ArrowVHDL.Circuit.Tools +where + + +-- Eingebunden werden für die Demo-Funktionen aus den +-- Systembibliotheken die folgenden Module: + +import System.IO (writeFile) +import System.Cmd (system) + +-- Daneben wird noch der \begriff{except}-Operator (\hsSource{(\\)}) +-- aus dem Listen-Modul benötigt: + +import Data.List ((\\)) + + +-- Schließlich werden eine ganze Reihe von Modulen aus der +-- \hsSource{Circuit}-Reihe verwendet: + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Show +import System.ArrowVHDL.Circuit.Graphs +import System.ArrowVHDL.Circuit.Auxillary +import System.ArrowVHDL.Circuit.Show.DOT +import System.ArrowVHDL.Circuit.Workers (mergeEdges) +import System.ArrowVHDL.Circuit.Tests + + +-- \subsection{Demo Funktionen} Mit \hsSource{write} und +-- \hsSource{genPicture} werden zwei Funktionen definiert, die auf das +-- Dateisystem zugreifen, und letztliche dazu verwendet werden, eine +-- Grafik einer Schaltung zu erstellen. Dazu wird mittels +-- \hsSource{show} die \begriff{.dot}-Darstellung des übergebenen +-- Schaltkreises erzeugt und im \hsSource{/tmp}-Folder abgespeichert. + +-- \hsSource{genPicture} greift dann auf die soeben erzeugte Datei zu, +-- und erzeugt aus dem \begriff{.dot}-File ein Bild mit der +-- Grafik. Hierbei wird vorausgesetzt, das auf dem System die +-- \begriff{graphviz}-Umgebung vorinstalliert ist. + +write x = writeFile "/tmp/test.dot" (Circuit.Show.DOT.showCircuit x) +genPicture = system "dot /tmp/test.dot -Tjpg -o /tmp/test.jpg" + + + +-- Mit der Funktion \hsSource{toCircuit} lässt sich aus einer minimal +-- Definition ein gültiger Schaltkreis erzeugen. Die minimale +-- Definition muss dabei wenigstens einen Namen, sowie die Anzahl der +-- eingehenden und Ausgehenden Pins enthalten. + +toCircuit :: (String, Int, Int) -> CircuitDescriptor +toCircuit (name, inPins, outPins) + = emptyCircuit { nodeDesc = nodedesc + } + where nodedesc = MkNode { label = name + , nodeId = 0 + , sinks = [0..(inPins -1)] + , sources = [0..(outPins -1)] + } + + +-- Die Funktion \hsSource{filterByName} ist ein Beispiel für die +-- Mächtigkeit des neuartigen Ansatzes. \hsSource{filterByName} geht +-- hier über eine Schaltung hinweg, und nimmt alle Vorkommenden +-- Bausteinen mit einem gewissen Namen heraus. So lassen sich zum +-- Testen sehr leicht von den enthaltenen Schaltungen, gewisse selbige +-- durch eine andere Version ersetzen. + +filterByName :: CircuitDescriptor -> String -> CircuitDescriptor +filterByName s n + = if ((label . nodeDesc) s == n) && (length (nodes s) < 1) + then NoDescriptor + else s { nodes = (map (flip filterByName n) $ nodes s) } + + +-- Zur Anwendung wird \hsSource{filterByName} in der nächsten +-- Funktion, nämlich in \hsSource{replace} gebracht. Hier übergibt man +-- die Schaltung in der man ändern möchte. Außerdem übergibt man ein +-- Tupel bestehenden aus einem \hsSource{from}-Baustein und einem +-- \hsSource{to}-Baustein, wobei nach dem \hsSource{from}-Baustein +-- gesucht wird, und dieser dann mit dem \hsSource{to}-Baustein +-- ersetzt wird. Als Ergebnis erhält man eine veränderte Schaltung + +replace :: CircuitDescriptor -> (CircuitDescriptor, CircuitDescriptor) -> CircuitDescriptor +replace s ft@(from, to) + | not $ isAtomic s + = s { nodes = map (flip replace $ ft) (nodes s) } + + | (label . nodeDesc) s == (label . nodeDesc) from + && length (sinks . nodeDesc $ s) == length (sinks . nodeDesc $ from) + && length (sources . nodeDesc $ s) == length (sources . nodeDesc $ from) + && length (sinks . nodeDesc $ s) == length (sinks . nodeDesc $ to) + && length (sources . nodeDesc $ s) == length (sources . nodeDesc $ to) + = to { nodeDesc = (nodeDesc to) { nodeId = (nodeId . nodeDesc) s } } + + | otherwise = s + +-- %% TODO : Programmiere: mark / cut / trim + + + +-- Die Funktion \hsSource{bypass} ermöglicht eine ähnlich +-- Funktionalität, wie auch schon \hsSource{filterByName} oder +-- \hsSource{replace}. Allerdings nimmt \hsSource{bypass} nur die +-- gefundenen Bausteine aus der Schaltung heraus. +-- +-- %%% TODO : Erklären was rebuildIf macht, und warum ;) +-- %%% TODO : grep wires usw. ist teil von rebuildIf + +bypass :: CircuitDescriptor -> CircuitDescriptor -> CircuitDescriptor +bypass s item + = s { nodes = ns + , edges = es + } + where (es, ns) = foldl (rebuildIf (\x -> label (nodeDesc x) == label (nodeDesc item))) (edges s, []) $ nodes s + + +rebuildIf :: (CircuitDescriptor -> Bool) -> ([Edge], [CircuitDescriptor]) -> CircuitDescriptor -> ([Edge], [CircuitDescriptor]) +rebuildIf isIt (super_es, new_ns) NoDescriptor = (super_es, new_ns) +rebuildIf isIt (super_es, new_ns) n + | isIt n && length (sinks . nodeDesc $ n) == length (sources . nodeDesc $ n) + = (new_es , new_ns) + + | otherwise + = (super_es, new_ns ++ [n']) + + where new_es = (super_es \\ (lws ++ rws)) ++ nws + lws = leftWires super_es (nodeId . nodeDesc $ n) + rws = rightWires super_es (nodeId . nodeDesc $ n) + nws = zipWith MkEdge (map sourceInfo lws) (map sinkInfo rws) + (es,ns) = foldl (rebuildIf isIt) (edges n, []) $ nodes n + n' = n { nodes = ns + , edges = es + } + + +grepWires :: (Edge -> Anchor) -> [Edge] -> CompID -> [Edge] +grepWires f es cid = filter (\e -> fst (f e) == Just cid) es + +leftWires :: [Edge] -> CompID -> [Edge] +leftWires = grepWires sinkInfo + +rightWires :: [Edge] -> CompID -> [Edge] +rightWires = grepWires sourceInfo + +solderWires :: ([Edge], [Edge]) -> [Edge] +solderWires = mergeEdges diff --git a/src/System/ArrowVHDL/Circuit/Workers.hs b/src/System/ArrowVHDL/Circuit/Workers.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Circuit/Workers.hs @@ -0,0 +1,153 @@ +-- In diesem Modul werden eine Reihe von \begriff{worker}-Funktionen definiert die alle einen übergebenen Wert verändern und die geänderte +-- Variante zurückliefern. + +module System.ArrowVHDL.Circuit.Workers +where + +-- Zur Funktionsdefinition werden Funktionen aus folgenden Modulen benötigt. + +import Data.List (nub, (\\)) + +import GHC.Exts (sortWith) + +import System.ArrowVHDL.Circuit.Descriptor +import System.ArrowVHDL.Circuit.Sensors +import System.ArrowVHDL.Circuit.Tests + + + +-- \subsection{CircuitDescriptor Funktionen} +-- Dieser Abschnitt befasst sich mit Funktionen, die auf \hsSource{CircuitDescriptor}en arbeiten. + +-- Mit der Funktion \hsSource{alterCompIDs} lassen sich alle Komponenten IDs innerhalb eines \hsSource{CircuitDescriptor}s verändern. Der erste +-- Parameter legt dabei die kleinst mögliche ID fest. + +alterCompIDs :: Int -> CircuitDescriptor -> CircuitDescriptor +alterCompIDs i sg + = sg { nodeDesc = nd { nodeId = nodeId nd + i } + , nodes = map (alterCompIDs i) $ nodes sg + , edges = map (\ (MkEdge (ci,pi) (co,po)) + -> (MkEdge (maybe ci (Just.(+i)) $ ci ,pi) + (maybe co (Just.(+i)) $ co ,po)) + ) $ edges sg + } + where nd = nodeDesc sg + + +-- Die Funktion \hsSource{dropCircuit} ermöglicht es, einzelne Schaltkreis-Beschreibungen aus dem \hsSource{CircuitDescriptor} zu entfernen. +-- Hierzu wird eine match-Funktion als erster Parameter erwartet. + +dropCircuit :: (CircuitDescriptor -> Bool) -> CircuitDescriptor -> CircuitDescriptor +dropCircuit f sg + = sg { nodes = newNodes + , edges = newEdges + } + where specific = filter f (nodes sg) + newEdges = foldl (flip dropEdgesBordering) (edges sg) (map (nodeId.nodeDesc) specific) + newNodes = map (dropCircuit f) $ nodes sg \\ specific + + +-- flatten} ist eine Funktion, welche die interne Struktur des \hsSource{CircuitDescriptor}s \begriff{glättet}. Jeder +-- CircuitDescriptor} der nicht Atomar ist, enthält weitere Unterstrukturen. Diese beschreiben, woraus dieser +-- CircuitDescriptor} aufgebaut wird. Enthält der \hsSource{CircuitDescriptor} unnötige Verschachtelungen, werden diese mittels +-- flatten} entfernt. + +-- Als Sonderfall gelten die Schaltungen, die Schleifen darstellen. Hier gibt es keine überflüssigen Verschachtelungen, mindestens aber muss +-- der Algorithmus zum erkennen solcher ein anderer sein, so dass \hsSource{flatten} auf diese Teilbereiche zunächst nicht angewandt werden +-- sollte. +flatten :: CircuitDescriptor -> CircuitDescriptor +flatten g + | isLoop g + = g + + | otherwise + = g { nodes = nub $ atomCIDs + , edges = esBetweenAtoms + } + where atomCIDs = filter isAtomic $ allCircuits g + esFromAtoms = concat $ map (fromCompEdges g . nodeId . nodeDesc) atomCIDs + esFromOuter = filter isFromOuter $ edges g + esBetweenAtoms = zipWith MkEdge (map sourceInfo $ esFromOuter ++ esFromAtoms) (map nextAtomOrOut $ esFromOuter ++ esFromAtoms) + nextAtomOrOut = (\e -> let (c, p) = nextAtomic g e + in if c == mainID then (Nothing, p) else (Just c, p)) + mainID = nodeId.nodeDesc $ g + + +-- Die Funktionen \hsSource{dropGenerated} sowie \hsSource{dropID} stellen Spezialfälle der \hsSource{dropCircuit} Funktion dar. +-- dropGenerated} löscht sämtliche \hsSource{CircuitDescriptor}en, die automatisch generiert wurden. Ebenso löscht \hsSource{dropID} +-- CircuitDescriptor}en, die den \hsSource{isID}-Test bestehen. \hsSource{isID} sowie \hsSource{isGenerated} sind im Modul +-- \ref{mod:Circuit.Tests} beschrieben. + +dropGenerated :: CircuitDescriptor -> CircuitDescriptor +dropGenerated = dropCircuit isGenerated + +dropID :: CircuitDescriptor -> CircuitDescriptor +dropID = dropCircuit isID + + + +-- Diese Funktionen arbeiten auf \hsSource{CircuitDescriptor}en, und erzeugen Kanten, oder es handelt sich um Funktionen, die aus bestehenden +-- Kanten neue generieren. + + +-- Mit der Funktion \hsSource{connectCID} lassen sich zwei \hsSource{CircuitDescriptor}en miteinander verbinden. Dabei werden zwei +-- \hsSource{CircuitDescriptor}en übergeben, sowie die Quell-Komponenten ID und die Ziel-Komponenten ID zusammen mit einer Ziel-Pin ID. Erzeugt +-- wird eine Kante, welche die Verbindung zwischen beiden \hsSource{CircuitDescriptor}en darstellt. Von der Quelle wird keine \hsSource{PinID} +-- benötigt, da hier auf den nächst freien Pin zurückgegriffen wird. Auf der Ziel-Seite ist es dann aber notwendig, einen Ziel-Pin zu +-- definieren. + +connectCID :: CircuitDescriptor -> CircuitDescriptor -> CompID -> (CompID, PinID) -> Edge +connectCID old_g g cidF (cidT,pidT) + = MkEdge (Just cidF, nextFpin) (Just cidT, pidT) + where nextFpin = head $ drop cntEsFrom $ sources.nodeDesc $ getComp old_g cidF + cntEsFrom = length $ filter (\x -> (not.isFromOuter $ x) && (srcComp x == cidF)) $ edges g + + +-- Zum entfernen von Kanten die an eine Komponente angrenzen, ist die Funktion \hsSource{dropEdgesBordering} da. Übergeben wird die ID der +-- Komponente, die heraus gelöst werden soll, sowie die Liste mit den betroffenen Kanten. Es wird dann eine neue List mit Kanten erstellt, die +-- nicht mehr zu der Komponente mit der besagten ID führen. Alle Kanten die nicht mehr an einer Komponente andocken, werden zusammengefügt. +-- Diese Funktion kann nur dann funktionieren, wenn die zu lösende Komponente genausoviele eingehende Pins, wie ausgehende Pins besitzt. +-- %%% TODO : Components with different InPinCount and OutPinCount have a PROBLEM + +dropEdgesBordering :: CompID -> [Edge] -> [Edge] +dropEdgesBordering cid es + = (es ++ mergeEdges (toIt, fromIt)) \\ (toIt ++ fromIt) + where toIt = filter ((== (Just cid)).fst.sinkInfo) $ es + fromIt = filter ((== (Just cid)).fst.sourceInfo) $ es + + +-- \hsSource{mergeEdges} ist eine Funktion, die zwei Listen mit Kanten entgegennimmt und diese beiden zusammenfasst. Kanten die auf einen Pin +-- enden und Kanten die vom gleichen Pin starten, werden zu einer Kante zusammengefasst. + +mergeEdges :: ([Edge], [Edge]) -> [Edge] +mergeEdges (xs, ys) + = zipWith (\x y -> MkEdge (sourceInfo x) (sinkInfo y)) xs' ys' + where x_snkPins = map snkPin xs + y_srcPins = map srcPin ys + xs' = sortWith snkPin $ filter (\edg -> (snkPin edg) `elem` y_srcPins) xs + ys' = sortWith srcPin $ filter (\edg -> (srcPin edg) `elem` x_snkPins) ys + + +-- Mit der \hsSource{fillEdgeInfoCompID} Funktion, lassen sich die Quell- und Ziel-Komponenten IDs in Kanten setzen, in denen bis dahin +-- \hsSource{Nothing} als Wert gespeichert ist. Dies ist dann notwendig, wenn eine neue Komponente in eine bestehende Struktur eingefügt wird. +-- Dies wird dann benötigt, wenn eine Komponente in eine Struktur eingefügt werden soll. Eine noch nicht integrierte Komponente bekommt ihre %% TODO : Werte ist sicher nicht das richtige wort hier +-- Werte von einer unbekannte Komponente (\hsSource{Nothing}) und liefert die Ergebnisse auch an \hsSource{Nothing}. Wird sie nun eine +-- Unterkomponente, so kann das \hsSource{Nothing} durch eine tatsächliche Komponenten ID ersetzt werden. + +fillEdgeInfoCompID :: CompID -> Edge -> Edge +fillEdgeInfoCompID cid (MkEdge (Nothing, srcPid) (snkInfo)) = (MkEdge (Just cid, srcPid) (snkInfo)) +fillEdgeInfoCompID cid (MkEdge (srcInfo) (Nothing, snkPid)) = (MkEdge (srcInfo) (Just cid, snkPid)) +fillEdgeInfoCompID _ e = e + + +-- Ein ähnliches Problem wie \hsSource{fillEdgeInfoCompID} wird auch von den Funktionen \hsSource{fillSrcInfoCompID} und +-- \hsSource{fillSnkInfoCompID} gelöst. Diese unterscheiden sich lediglich darin, dass diese Funktionen jeweils nur die Quell-Pins oder nur die +-- Ziel-Pins betreffen. + +fillSrcInfoCompID :: CompID -> Edge -> Edge +fillSrcInfoCompID cid (MkEdge (Nothing, srcPid) (snkCid, snkPid)) + = (MkEdge (Just cid, srcPid) (snkCid, snkPid)) + +fillSnkInfoCompID :: CompID -> Edge -> Edge +fillSnkInfoCompID cid (MkEdge (srcCid, srcPid) (Nothing, snkPid)) + = (MkEdge (srcCid, srcPid) (Just cid, snkPid)) diff --git a/src/System/ArrowVHDL/TEA.hs b/src/System/ArrowVHDL/TEA.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/TEA.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE Arrows, + NoMonomorphismRestriction, + RebindableSyntax #-} + -- GADTs #-} +module System.ArrowVHDL.TEA where + +import Data.Char (digitToInt, ord, chr) +import qualified Data.Bits as B +import Data.Word (Word32(..)) +import Prelude hiding (cycle) + +import Control.Category +import System.ArrowVHDL.Circuit +import System.ArrowVHDL.Circuit.Arrow +import System.ArrowVHDL.Circuit.Defaults hiding (Value, Key) + +type Key = (Word32, Word32, Word32, Word32) +type HalfKey = (Word32, Word32) +type Value = (Word32, Word32) +type Round = Int + +type TL4 + = (Bool, (Bool, (Bool, (Bool)))) + +type TL32 + = (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, + (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, + (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, + (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, (Bool, Bool + ))))))))))))))))))))))))))))))) +type KeyTL = (TL32, TL32, TL32, TL32) +type HalfKeyTL = (TL32, TL32) +type ValueTL = (TL32, TL32) +type RoundTL = TL32 + +-- aXorTL4 +-- = aXor +-- >:> aXor +-- >:> aXor +-- >:> aXor +-- where +-- aA >:> aB = ((aFst *** aFst) >>> aA) &&& ((aSnd *** aSnd) >>> aB) +-- infixr 4 >:> + +-- aXorTL32 +-- = aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor +-- >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor +-- >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor +-- >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor >:> aXor +-- where +-- aA >:> aB = ((aFst *** aFst) >>> aA) &&& ((aSnd *** aSnd) >>> aB) +-- infixr 4 >:> + +-- aOrTL32 +-- = aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr +-- >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr +-- >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr +-- >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr >:> aOr +-- where +-- aA >:> aB = ((aFst *** aFst) >>> aA) &&& ((aSnd *** aSnd) >>> aB) +-- infixr 4 >:> + +magicConstant = 0x9e3779b9 + +-- |`delta` is the function, that considering the round number, +-- calculates the magic number. +delta :: Int -> Word32 +delta r = fromIntegral r * magicConstant + + +-- |Here comes a function `cycleN` that calculates the cypher of the +-- TEA. It therefore takes a round counter and calculates the TEA with +-- exact that amount of rounds. +cycleN :: Int -> Key -> Value -> Value +cycleN n = cycleN' (1, n) + +-- |Another more specific version of `cycleN` is `cycleN'`. This +-- function has a more complex round counter (Tuple of Int vs. single +-- Int). The first element of the tuple is the actual round counter; +-- the second element count's backward and acts as the recursion +-- break. +cycleN' :: (Round, Int) -> Key -> Value -> Value +cycleN' (_,0) _ v = v +cycleN' (r,n) k v = cycleN' (r+1, n-1) k (cycle r k v) + +-- |`cycle` without any naming suffixes is the function that actually +-- calculates one round of the TEA. +cycle :: Round -> Key -> Value -> Value +cycle r (k0, k1, k2, k3) value + = let value' = feistel1 value + in feistel2 value' + where feistel1 = feistel r (k0, k1) + feistel2 = feistel r (k2, k3) + +-- |The `feistel` function contains the logic of the TEA. It is +-- similar to the depicted definition inside the wikipedia-article on +-- TEA: https://en.wikipedia.org/wiki/Tiny_Encryption_Algorithm +feistel :: Round -> HalfKey -> Value -> Value +feistel r (kA, kB) (vA, vB) + = (vB, vA + tB) + where t1 = kA + (vB `B.shift` 4) + t2 = vB + delta r + t3 = kB + (vB `B.shift` (-5)) + tB = t1 `B.xor` t2 `B.xor` t3 + +-- |The `feistel'functional` function contains the logic of the TEA. It is +-- similar to the depicted definition inside the wikipedia-article on +-- TEA: https://en.wikipedia.org/wiki/Tiny_Encryption_Algorithm +feistel'functional :: Round -> HalfKey -> Value -> Value +feistel'functional r (kA, kB) (vA, vB) + = (vB, vA + tB) + where t1 = kA + (vB `B.shift` 4) + t2 = vB + delta r + t3 = kB + (vB `B.shift` (-5)) + tB = t1 `B.xor` t2 `B.xor` t3 + +feistel'arrow :: Round -> HalfKey -> Value -> Value +feistel'arrow r key val + = runGrid aTEA $ (key, val) + where aTEA :: (Arrow a) => Grid a (HalfKey, Value) Value -- ((K0, K1), (V0, V1)) + aTEA = aDistr -- (((K0, K1), V0), ((K0, K1), V1)) + >>> first + ( aSnd -- (V0, ((K0, K1), V1)) + ) + >>> second + ( ( aFlip -- &&& aSnd -- (V0, ((V1, (K0, K1)), V1)) + >>> aDistr &&& aFst -- (V0, ((((V1, K0), (V1, K1)), V1), V1)) + >>> ( ((first aSHL4) + *** (first aSHR5)) + *** aXorDeltaR + ) -- (V0, ((((S1, K0), (S1, K1)), T3), V1)) + >>> first (aXor *** aXor) -- (V0, (((T1, T2), T3), V1)) + >>> first aXor -- (V0, ((T12, T3), V1)) + >>> aXor -- (V0, (TB, V1)) + ) + &&& aSnd + ) + >>> a_aBC2ABc + >>> first aXor + >>> aFlip + aSHL4 :: (Arrow a, B.Bits b) => Grid a b b + aSHL4 = (aId &&& (aConst (4 :: Int))) >>> aShiftL + + aSHR5 :: (Arrow a, B.Bits b) => Grid a b b + aSHR5 = (aId &&& (aConst (5 :: Int))) >>> aShiftR + + aXorDeltaR :: (Arrow a) => Grid a Word32 Word32 + aXorDeltaR = (aId &&& (aConst (delta r))) >>> aXor + + +-- key :: Key +-- key = (65, 65, 65, 65) -- AAAA + +-- testMessage = "Hello World!" + +-- msg2vals :: String -> [Value] +-- msg2vals [] = [] +-- msg2vals (s0:[]) = msg2vals [s0, '\0'] +-- msg2vals (s0:s1:ses) +-- = (fromIntegral $ ord s0, fromIntegral $ ord s1) : (msg2vals ses) + +-- vals2msg :: [Value] -> String +-- vals2msg [] = "" +-- vals2msg ((v0,v1):vs) = (chr (fromIntegral v0): (chr (fromIntegral v1) : (vals2msg vs))) + +-- aFeistel +-- = proc ((v0, v1), (k0, k1)) -> do +-- vsl <- aShl -< (v1, 4) +-- vsr <- aShr -< (v1, 5) + +-- t1 <- aXor -< (k0, vsl) +-- t2 <- aXor -< (d, v1) +-- t3 <- aXor -< (k1, vsr) + +-- t4 <- aOr -< (t1, t2) +-- t5 <- aOr -< (t4, t3) + +-- v0' <- aId -< (v1) +-- v1' <- aXor -< (v0, t5) +-- returnA -< (v0', v1') +-- where +-- aShl = aShiftL +-- aShr = aShiftR +-- d = (delta 0) + +-- aCycle +-- = proc ((v0, v1), ((k0, k1), (k2, k3))) -> do +-- (v0', v1') <- aFeistel -< ((v0, v1), (k0, k1)) +-- (v0'', v1'') <- aFeistel -< ((v0', v1'), (k2, k3)) +-- returnA -< (v0'', v1'') + + +aShiftL4_XorKey + = first + ( aDup + >>> second (aConst 4) + >>> aShiftL + ) + >>> aAdd + -- >>> aXor + +aShiftR5_XorKey + = first + ( aDup + >>> second (aConst 5) + >>> aShiftR + ) + >>> aAdd + -- >>> aXor + +aXorDelta + = aId &&& (aConst 2654435769) + >>> aAdd + -- >>> aXor + +aFeistelTest + = (aFst >>> aSnd) &&& (aFst >>> aFst) &&& (first aSnd) + >>> second + ( second + ( aDistr &&& aFst + >>> (aShiftL4_XorKey *** aShiftR5_XorKey) *** aXorDelta + >>> first aOr + >>> aOr + ) + ) + >>> second aAdd + +aCycleTest + = a_aBC2ABc + >>> first aFeistelTest + >>> aFeistelTest + diff --git a/src/System/ArrowVHDL/Test.hs b/src/System/ArrowVHDL/Test.hs new file mode 100644 --- /dev/null +++ b/src/System/ArrowVHDL/Test.hs @@ -0,0 +1,12 @@ +module System.ArrowVHDL.Test where + +import Prelude + +import Control.Category ((>>>)) + +import System.ArrowVHDL.Circuit +import System.ArrowVHDL.Circuit.Arrow +import System.ArrowVHDL.Circuit.IEEE_STD_LOGIC_1164 + +aBlub :: (Arrow a) => Grid a (Bool, Bool) Bool +aBlub = aXor >>> aNot