diff --git a/hxt-relaxng.cabal b/hxt-relaxng.cabal
--- a/hxt-relaxng.cabal
+++ b/hxt-relaxng.cabal
@@ -1,6 +1,6 @@
 -- arch-tag: Haskell XML Toolbox main description file
 Name:           hxt-relaxng
-Version:        9.1.4
+Version:        9.1.5
 Synopsis:       The HXT RelaxNG validator
 Description:    The HXT RelaxNG validator
 License:        MIT
diff --git a/src/Text/XML/HXT/RelaxNG/CreatePattern.hs b/src/Text/XML/HXT/RelaxNG/CreatePattern.hs
--- a/src/Text/XML/HXT/RelaxNG/CreatePattern.hs
+++ b/src/Text/XML/HXT/RelaxNG/CreatePattern.hs
@@ -36,20 +36,23 @@
 -- | Creates the 'Pattern' datastructure from a simplified Relax NG schema.
 
 createPatternFromXmlTree :: LA XmlTree Pattern
-createPatternFromXmlTree = createPatternFromXml $< createEnv
- where
- -- | Selects all define-pattern and creates an environment list.
- -- Each list entry maps the define name to the children of the define-pattern.
- -- The map is used to replace a ref-pattern with the referenced define-pattern.
- createEnv :: LA XmlTree Env
- createEnv = listA $ deep isRngDefine
-                     >>>
-                     (getRngAttrName &&& getChildren)
+createPatternFromXmlTree = arr patternFromXmlTree
 
+patternFromXmlTree :: XmlTree -> Pattern
+patternFromXmlTree t = patternFromXml env t
+   where env = map (fmap $ patternFromXml env) definitions
+         definitions = runLA createDefinitionList t
+         createDefinitionList :: LA XmlTree (String, XmlTree)
+         createDefinitionList = deep isRngDefine
+                                >>>
+                                (getRngAttrName &&& getChildren)
 
+patternFromXml :: PatternEnv -> XmlTree -> Pattern
+patternFromXml env = head . runLA (createPatternFromXml env)
+
 -- | Transforms each XML-element to the corresponding pattern
 
-createPatternFromXml :: Env -> LA XmlTree Pattern
+createPatternFromXml :: PatternEnv -> LA XmlTree Pattern
 createPatternFromXml env
  = choiceA
    [ isRoot          :-> processRoot env
@@ -69,7 +72,7 @@
    , this            :-> mkRelaxError "internal HXT RelaxNG error"
    ]
 
-processRoot :: Env -> LA XmlTree Pattern
+processRoot :: PatternEnv -> LA XmlTree Pattern
 processRoot env
   = getChildren
     >>>
@@ -80,7 +83,7 @@
     ]
 
 
-processGrammar :: Env -> LA XmlTree Pattern
+processGrammar :: PatternEnv -> LA XmlTree Pattern
 processGrammar env
   = getChildren
     >>>
@@ -98,19 +101,20 @@
   to find the corresponding define-pattern.
   Haskells lazy-evaluation is used to transform circular structures.
 -}
-mkRelaxRef :: Env -> LA XmlTree Pattern
+mkRelaxRef :: PatternEnv -> LA XmlTree Pattern
 mkRelaxRef e
  = getRngAttrName
    >>>
    arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")
-              . lookup n $ transformEnv e
+              $ lookup n e
        )
- where
+{-
+   where
  transformEnv :: [(String, XmlTree)] -> [(String, Pattern)]
  transformEnv env = [ (treeName, (transformEnvElem tree env)) | (treeName, tree) <- env]
  transformEnvElem :: XmlTree -> [(String, XmlTree)] -> Pattern
  transformEnvElem tree env = head $ runLA (createPatternFromXml env) tree
-
+-}
 
 -- | Transforms a notAllowed-element.
 mkNotAllowed :: LA XmlTree Pattern
@@ -144,7 +148,7 @@
 
 
 -- | Transforms a choice-element.
-mkRelaxChoice :: Env -> LA XmlTree Pattern
+mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern
 mkRelaxChoice env
     = ifA ( getChildren >>.
             ( \ l -> if length l == 1 then l else [] )
@@ -153,7 +157,7 @@
       ( getTwoChildrenPattern env >>> arr2 Choice )
 
 -- | Transforms a interleave-element.
-mkRelaxInterleave :: Env -> LA XmlTree Pattern
+mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern
 mkRelaxInterleave env
     = getTwoChildrenPattern env
       >>>
@@ -161,7 +165,7 @@
 
 
 -- | Transforms a group-element.
-mkRelaxGroup :: Env -> LA XmlTree Pattern
+mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern
 mkRelaxGroup env
     = getTwoChildrenPattern env
       >>>
@@ -169,7 +173,7 @@
 
 
 -- | Transforms a oneOrMore-element.
-mkRelaxOneOrMore :: Env -> LA XmlTree Pattern
+mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern
 mkRelaxOneOrMore env
     = getOneChildPattern env
       >>>
@@ -177,7 +181,7 @@
 
 
 -- | Transforms a list-element.
-mkRelaxList :: Env -> LA XmlTree Pattern
+mkRelaxList :: PatternEnv -> LA XmlTree Pattern
 mkRelaxList env
     = getOneChildPattern env
       >>>
@@ -185,7 +189,7 @@
 
 
 -- | Transforms a data- or dataExcept-element.
-mkRelaxData :: Env -> LA XmlTree Pattern
+mkRelaxData :: PatternEnv -> LA XmlTree Pattern
 mkRelaxData env
   = ifA (getChildren >>> isRngExcept)
      (processDataExcept >>> arr3 DataExcept)
@@ -243,7 +247,7 @@
 -- | Transforms a attribute-element.
 -- The first child is a 'NameClass', the second (the last) one a pattern.
 
-mkRelaxAttribute :: Env -> LA XmlTree Pattern
+mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern
 mkRelaxAttribute env
     = ( ( firstChild >>> createNameClass )
         &&&
@@ -254,7 +258,7 @@
 
 -- | Transforms a element-element.
 -- The first child is a 'NameClass', the second (the last) one a pattern.
-mkRelaxElement :: Env -> LA XmlTree Pattern
+mkRelaxElement :: PatternEnv -> LA XmlTree Pattern
 mkRelaxElement env
     = ( ( firstChild >>> createNameClass )
         &&&
@@ -333,12 +337,12 @@
               ]
 
 
-getOneChildPattern :: Env -> LA XmlTree Pattern
+getOneChildPattern :: PatternEnv -> LA XmlTree Pattern
 getOneChildPattern env
     = firstChild >>> createPatternFromXml env
 
 
-getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)
+getTwoChildrenPattern :: PatternEnv -> LA XmlTree (Pattern, Pattern)
 getTwoChildrenPattern env
     = ( getOneChildPattern env )
         &&&
diff --git a/src/Text/XML/HXT/RelaxNG/DataTypes.hs b/src/Text/XML/HXT/RelaxNG/DataTypes.hs
--- a/src/Text/XML/HXT/RelaxNG/DataTypes.hs
+++ b/src/Text/XML/HXT/RelaxNG/DataTypes.hs
@@ -28,6 +28,8 @@
 
 type Env = [(String, XmlTree)]
 
+type PatternEnv = [(String, Pattern)]
+
 -- | Start of a context attribute value
 -- (see also: 'Text.XML.HXT.RelaxNG.Simplification.simplificationStep1')
 --
diff --git a/src/Text/XML/HXT/RelaxNG/Simplification.hs b/src/Text/XML/HXT/RelaxNG/Simplification.hs
--- a/src/Text/XML/HXT/RelaxNG/Simplification.hs
+++ b/src/Text/XML/HXT/RelaxNG/Simplification.hs
@@ -51,12 +51,10 @@
     , fromMaybe
     )
 import Data.List
-    ( elemIndices
-    , nub
-    , deleteBy
-    , find
-    , (\\)
+    ( (\\)
     )
+import Data.Map
+    ( Map, fromListWithKey, toList )
 
 infixr 1 !>>>
 
@@ -975,11 +973,12 @@
             >>>
             -- For each grammar element, all define elements with the same
             -- name are combined together.
-            ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )
+            -- ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )
+            ( mergeCombinedPatternMap "define" $< getPatternNameMapInGrammar "define" (combinePatterns "define" True))
             >>>
             -- Similarly, for each grammar element all start elements
             -- are combined together.
-            ( combinePatternList "start" $< (getPatternNamesInGrammar "start" >>> arr nub) )
+            ( mergeCombinedPatternMap "start" $< (getPatternNameMapInGrammar "start" (combinePatterns "start" False)) )
           )
           `when`
           isRngGrammar
@@ -1034,6 +1033,31 @@
         )
       ) `when` collectErrors
     where
+    getPatternNameMapInGrammar :: (ArrowXml a) => String -> (String -> XmlTree -> XmlTree -> XmlTree)
+                                  -> a XmlTree (Map String XmlTree)
+    getPatternNameMapInGrammar pattern combinator
+        = (
+              getChildren 
+              >>>
+              allGrammarPatterns
+              >>>
+              (getRngAttrName &&& this)
+          )
+          >.
+          fromListWithKey combinator
+        where allGrammarPatterns 
+                  = choiceA
+                    [ hasRngElemName pattern
+                      :->
+                      this
+                    , isRngGrammar 
+                      :-> 
+                      none
+                    , this
+                      :->
+                      (getChildren >>> allGrammarPatterns)
+                    ]
+
     getPatternNamesInGrammar :: (ArrowXml a) => String -> a XmlTree [String]
     getPatternNamesInGrammar pattern
         = processChildren
@@ -1135,134 +1159,50 @@
     deleteAllDefines :: IOSArrow XmlTree XmlTree
     deleteAllDefines = processTopDown $ none `when` isRngDefine
 
-    combinePatternList :: String -> [String] -> IOSArrow XmlTree XmlTree
-    combinePatternList _ [] = this
-    combinePatternList pattern (x:xs)
-        = (replaceChildren $ combinePattern pattern x)
-          >>>
-          combinePatternList pattern xs
-
-    -- combine a define- or start-pattern (first parameter) with a
-    -- specific name (second parameter)
-    combinePattern :: String -> String -> IOSArrow XmlTree XmlTree
-    combinePattern pattern name
-        = createPatternElems pattern name
-          <+>
-          (getChildren >>> deletePatternElems pattern name)
-
-    createPatternElems :: String -> String -> IOSArrow XmlTree XmlTree
-    createPatternElems pattern name
-        = ( ( listA (getElems pattern name >>> getRngAttrCombine)
-              >>>
-              checkPatternCombine pattern name
-            )
-            -- After determining this unique value, the combine attributes are removed.
-            &&&
-            listA (getElems pattern name >>> removeAttr "combine"))
-          >>>                           -- ((errorCode::Int, errorMessage::String), result::XmlTrees)
-          choiceA
-          [ isA (\ ((code, _) , _)  -> code == 0)
-            :->
-            (mkRelaxError "" $< arr (snd . fst))
-
-          , isA (\ ((code, str) , _) -> code == 1 && str == "")
-            :->
-            arrL snd
-
-          , isA (\ ((code, str) , _) -> code == 1 && str /= "")
-            :->
-            ( createPatternElem pattern name $<<
-              ( arr (snd . fst) &&& (arr snd) )
-            )
-
-          , this
-            :->
-            ( mkRelaxError ""
-              ( "Can't create Pattern: " ++ show pattern ++
-                " with name " ++ show name ++ " in createPatternElems"
-              )
-            )
-          ]
-
-    createPatternElem :: (ArrowXml a) => String -> String -> String -> XmlTrees -> a n XmlTree
-    createPatternElem pattern name combine trees
-        = mkRngElement pattern (mkRngAttrName name)
-          ( ( mkRngElement combine none
-              (arrL (const trees) >>> getChildren)
-            )
-            >>>
-            (wrapPattern2Two $< getQName)
-          )
-
-    checkPatternCombine :: (ArrowXml a) => String -> String -> a [String] (Int, String)
-    checkPatternCombine pattern name
-        = choiceA
-          [ -- just one pattern with that name -> ok, no combine is needed
-            (isA (\ cl -> length cl == 1))
-            :->
-            constA (1, "")
-
-          , (isA (\ cl -> (length $ elemIndices "" cl) > 1))
-            :->
-            constA ( 0
-                   , "More than one " ++ pattern ++ "-Pattern: " ++ show name ++
-                     " without an combine-attribute in the same grammar"
-                   )
-
-          , (isA (\ cl -> (length $ nub $ deleteBy (==) "" cl) > 1))
-            :->
-            arr (\ cl -> ( 0
-                         , "Different combine-Attributes: " ++
-                           (formatStringListQuot $ noDoubles cl) ++
-                           " for the " ++ pattern ++ "-Pattern " ++
-                           show name ++ " in the same grammar"
-                         )
-                )
-
-          , -- ok -> combine value is returned
-            this
-            :->
-            arr (\ cl -> (1, fromJust $ find (/= "") cl))
-          ]
-
-    isElemWithNameValue :: (ArrowXml a) => String -> String -> a XmlTree XmlTree
-    isElemWithNameValue ename nvalue
-        = ( hasRngElemName ename
-            >>>
-            getRngAttrName
-            >>>
-            isA (== nvalue)
-          )
-          `guards` this
-
-    getElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree
-    getElems pattern name
-        = getChildren
-          >>>
-          choiceA
-          [ isElemWithNameValue pattern name
-            :->
-            (this <+> getElems pattern name)
-          , isRngGrammar
-            :-> none
-          , this
-            :->
-            getElems pattern name
-          ]
-
-    deletePatternElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree
-    deletePatternElems pattern name
-        = choiceA
-          [ isElemWithNameValue pattern name
-            :->
-            none
-          , isRngGrammar
-            :-> this
-          , this
-            :->
-            processChildren ( deletePatternElems pattern name )
-          ]
+    combinePatterns :: String -> Bool -> String -> XmlTree -> XmlTree -> XmlTree
+    combinePatterns pattern keepName name t1 t2 = combined
+        where [combined] = runLA (combine $<< parts) undefined
+              combine (c1, d1) (c2, d2)
+                  | c1 == "" && c2 == "" = mkRngRelaxError
+                                           >>>
+                                           addRngAttrDescr ("More than one " ++ pattern ++ "-Pattern: " ++ show name 
+                                                            ++ " without a combine-attribute in the same grammar")
+                  | c1 == "" = combineWith c2 d1 d2
+                  | c2 == "" = combineWith c1 d1 d2
+                  | c1 == c2 = combineWith c1 d1 d2
+                  | otherwise = mkRngRelaxError
+                                >>>
+                                addRngAttrDescr ("Different combine-Attributes: " ++
+                                                 (formatStringListQuot [c1, c2]) ++
+                                                 " for the " ++ pattern ++ "-Pattern " ++
+                                                 show name ++ " in the same grammar")
+              combineWith :: String -> XmlTree -> XmlTree -> LA n XmlTree
+              combineWith c d1 d2 = mkRngElement pattern
+                                        (mkRngAttr "combine" (constA c) <+> if keepName then mkRngAttrName name else none)
+                                        (mkRngElement c none $ arrL $ const [d1, d2])
+              parts = (
+                       (constA t1 >>> getRngAttrCombine &&& getChildren)
+                       &&&
+                       (constA t2 >>> getRngAttrCombine &&& getChildren)
+                      )
 
+    mergeCombinedPatternMap :: String -> Map String XmlTree -> IOSArrow XmlTree XmlTree
+    mergeCombinedPatternMap pattern definitions
+        = replaceChildren ((constL (toList definitions) >>> arr snd)
+                           <+>
+                           (getChildren >>> deleteDefinitions))
+          where deleteDefinitions 
+                   = choiceA
+                     [ hasRngElemName pattern
+                       :->
+                       none
+                     , isRngGrammar 
+                       :-> 
+                       this
+                     , this
+                       :->
+                       processChildren deleteDefinitions
+                     ]
 
 -- ------------------------------------------------------------
 
diff --git a/src/Text/XML/HXT/RelaxNG/SystemConfig.hs b/src/Text/XML/HXT/RelaxNG/SystemConfig.hs
--- a/src/Text/XML/HXT/RelaxNG/SystemConfig.hs
+++ b/src/Text/XML/HXT/RelaxNG/SystemConfig.hs
@@ -35,7 +35,11 @@
 withRelaxNG s                   = setS (theRelaxValidate
                                         .&&&. theRelaxSchema
                                         .&&&. theRelaxValidator
-                                       ) (True, (s, validateDocumentWithRelaxSchema [] s))
+                                       ) ( not (null s)		-- null s turns off validation
+                                         , ( s
+                                           , validateDocumentWithRelaxSchema [] s
+                                           )
+                                         )
 
 withRelaxCheckRestr             ::  Bool -> SysConfig
 withRelaxCheckRestr             = setS theRelaxCheckRestr