Сортировка сдвигами

movingSort :: [Int] -> Int
movingSort [] = 0
movingSort x 
    | isSorted x = 0
    | isSorted $ tail x = length x - 1
    | otherwise = -1
 
isSorted :: [Int] -> Bool
isSorted [] = True
isSorted (x:[]) = True
isSorted (x:xs) = x <= head xs && isSorted xs

> movingSort [4,1,2,3]
3
> movingSort [4,5,1,2,3]
-1

import Control.Monad.Fix
 
movingSort :: [Int] -> Int
movingSort a = fix (\f a n k m -> let n' = if k == 0 then 0 else n+1 in case a of
  x:xs| x >= m    -> f xs n' k x
      | k == 0    -> f xs 0  1 x
      | otherwise -> -1
  _               -> n' ) a 0 0 (head a)

import Control.Monad.Fix
 
movingSort :: [Int] -> Int
movingSort a = fix (\f a n k m s -> let n' = if k then 0 else n+1 in case a of
  x:xs| x >= m    -> f xs n' k     x s
      | k         -> f xs 0  False x s
      | otherwise -> -1
  _               -> if m <= s || k then n' else -1 ) a 0 True (head a) (head a)

isSorted :: [Int] -> Bool
isSorted [x] = True
isSorted (x:xs) = (x < head xs) && isSorted xs
 
mvSort :: [Int] -> Int -> Int
mvSort x n | (n > lx) = (-1)
           | isSorted x = n
           | otherwise = mvSort ((last x) : (take (lx-1) x)) (n+1)
            where lx=length x
 
Main> mvSort [4,1,2,3] 0
3
Main> mvSort [4,5,1,2,3] 0
3

import Data.Function

isSorted :: [Int] -> Bool
isSorted [x] = True
isSorted (x:xs) = (x < head xs) && isSorted xs
 
rotate :: [a] -> [a]
rotate [] = []
rotate x = (last x) : (take (l-1) x)
           where l=length x
           
mvSort' :: [Int] -> Int -> Int
mvSort' x n | (n>l) = (-1)
            | isSorted x = n
            | otherwise = mvSort' (rotate x) (n+1)
             where l=length x           
 
mvSort :: [Int] -> Int
mvSort x = mvSort' x 0

shiftSort:: [Int] -> Int
shiftSort [] = 0
shiftSort [_] = 0
shiftSort (frst':xs) = let (_,_,res)= loop (frst':xs) 0 (negate 1) in res  
  where loop [last'] ix pos = ([], ix, if pos < 0 then 0 
                                       else if pos>0 && frst' < last' 
                                            then -1 else pos)
        loop (l:r:xs') ix pos = if l > r then 
                                    if pos >=0 then ([],0,-1) 
                                    else loop (r:xs') (ix+1) (1 + length xs') 
                                else loop (r:xs') (ix+1) pos

isSorted :: [Int] -> Bool  -- проверка, отсортирован ли список
isSorted [x] = True  --   список из одного элемента всегда отсортирован
isSorted (x:xs) = (x < head xs) && isSorted xs -- а иначе список отсортирован, если его первый эл-т меньше 
                                                              -- второго и отсортирован хвост 
 
rotate :: [a] -> [a] -- вращение
rotate [] = []  -- вращение пустого дает пустой
rotate x = (last x) : (take (l-1) x) -- иначе берем последний эл-т и присоединяем его первым к списку без последнего
           where l=length x -- l - длина списка
           
mvSort' :: [Int] -> Int -> Int  -- рекурсивная программа с накопительным параметром
mvSort' x n | (n>l) = (-1) -- если число вращений превысило длину - отсортировать не удастся
            | isSorted x = n -- если отсортировали - вернем количество
            | otherwise = mvSort' (rotate x) (n+1) -- иначе рекурсивный вызов с увеличением накоп. параметра
             where l=length x           
 
mvSort :: [Int] -> Int -- парадная функция (только для того, чтобы не задавать 0 при вызове
mvSort x = mvSort' x 0

shiftSort:: [Int] -> Int -- ф-ия находит, сколько раз нужно выполнить циклический сдвиг
shiftSort [] = 0         -- для упорядочивания списка
shiftSort [_] = 0        -- для этого проходим по списку сравнивая соседнии элементы
                         -- там где неубывание нарушится, там и место проворота
shiftSort (frst':xs) = -- первый элемент нам понадобится для сравнения с последним 
    snd $ loop -- рекурсивная ф-ия с двумя аргументами, возвращает кортеж из них же 
                              (frst':xs) -- не просмотренная ещё часть списка 
                              (negate 1) -- позиция проворота или -1, если ещё не нашли  
  where loop [last'] pos = -- Добрались до последнего элемента 
         ([], if pos < 0 then 0 -- если прокручивать список не нужно, то и нет смысла 
                                -- сравнивать первый элемент с последним - они не будут рядом 
              else if pos>0 && frst' < last'  then -1 -- одна позиция для проворота уже была. две быть не может 
              else pos) -- успех
        loop (l:r:xs') pos = if l > r then -- неубывание нарушено  
                                    if pos >=0 then ([],-1) -- это уже не первое. Отсортировать не получится.
                                    else loop (r:xs') (1 + length xs') -- помечаем место откуда крутить список
                             else loop (r:xs') pos -- список пока неубыват, переходим к следующему

{-# Language MultiWayIf,LambdaCase#-}
import Data.Function
 
shiftSort:: [Int] -> Int 
shiftSort [] = 0         
shiftSort [_] = 0
shiftSort (frst':xs) = snd $ loop (frst':xs) (negate 1) 
  where loop [last'] pos = ([], if pos < 0 then 0 
              else if pos>0 && frst' < last'  then -1
              else pos)
        loop (l:r:xs') pos = if l > r then 
                                    if pos >=0 then ([],-1)
                                    else loop (r:xs') (1 + length xs')
                             else loop (r:xs') pos
 
shiftSort:: [Int] -> Int
shiftSort [] = 0         
shiftSort [_] = 0        
shiftSort (frst':xs) = snd $ loop (frst':xs) (-1)  
  where 
    loop [last'] pos = ([],
      if  | pos < 0                  -> 0
          | pos > 0 && frst' < last' -> -1
          | otherwise                -> pos)
    loop (l:r:xs') pos 
      | l <= r    = loop (r:xs') pos
      | pos >=0   = ([],-1) 
      | otherwise = loop (r:xs') (1 + length xs')
 
shiftSort:: [Int] -> Int
shiftSort x = case x of
  f:xs -> let loop x pos = case x of
                l:r:xs'| l <= r           -> loop (r:xs') pos
                       | pos >= 0         -> ([],-1) 
                       | otherwise        -> loop (r:xs') (1 + length xs')
                [l]    | pos < 0          -> ([],0  )
                       | pos > 0 && f < l -> ([],-1 )
                       | otherwise        -> ([],pos) 
          in  snd $ loop (f:xs) (-1)
  _    -> 0 
 
shiftSort:: [Int] -> Int
shiftSort = \case
  f:xs -> snd $ fix (\loop x pos -> case x of
      l:r:xs'| l <= r           -> loop (r:xs') pos
             | pos >= 0         -> ([],-1) 
             | otherwise        -> loop (r:xs') (1 + length xs')
      [l]    | pos < 0          -> ([],0  )
             | pos > 0 && f < l -> ([],-1 )
             | otherwise        -> ([],pos) 
    ) (f:xs) (-1)
  _    -> 0

{-# Language MultiWayIf,LambdaCase#-}

{-# Language MultiWayIf,LambdaCase, ParallelListComp  #-}
 
sSort:: [Int] -> Int
sSort = \case
  f:xs -> case [z|(x,y,z)<-[(x,y,(length xs)-z)|x<-(init $ f:xs) |y<-xs|z<-[0,1..]],x>y] of
            []  -> 0
            [0] -> 0
            [i] -> if | f < (last xs) -> -1
                      | True -> i
            _   -> -1     
  _    -> 0

sSort:: [Int] -> Int
sSort x = case [ n | (n,a) <- zip [1..] $ zipWith (-) x (last x:init x) , a < 0] of
  []  -> 0
  [1] -> 0
  [n] -> length x - n + 1
  _   -> -1

{-# Language ParallelListComp  #-}
 
sSort:: [Int] -> Int
sSort x   = case [ n | (n,a) <- [(n,a<b)|n<-[1..]|a<-x|b<-(last x:init x)], a] of
  []  -> 0
  [1] -> 0
  [n] -> length x - n + 1
  _   -> -1

{-# Language ParallelListComp  #-}
 
sSort:: [Int] -> Int
sSort x   = case [ n | (n,a) <- [(n,a<b)|n<-[0..]|a<-x|b<-(last x:init x)], a] of
  []  -> 0
  [0] -> 0
  [n] -> length x - n 
  _   -> -1