مطلوب حل برمجي لمعرفة الناجي الوحيد من لعبة الموت

[AbuuAhmed]

منقول:

أوقف حاكم 100 سجين في دائرة
وأرقامهم من 1 إلى 100
أعطى الأول سيفا فقتل رقم 2
ثم أخذ رقم 3 السيف وقتل رقم 4
.
.
أخذ رقم 99 السيف وقتل رقم 100
أخذ رقم 1 السيف وقتل رقم 3

استمرت لعبة الموت حتى بقي واحد فقط.
ما رقم الذي تبقى؟

 

محاولاتكم يجب أن تكون برمحيا وليست رياضياتيا، فرياضياتيا لها معادلة أو قانون مسمى.
لكم مطلق الحرية باستخدام الأكواد أو الجداول والاستعلامات أو بهما معا أو بأي مكون من مكونات الأكسس.
الحصول على الإجابة الصحيحة بحد ذاته تميز ولكن لو تم بواسطة الشفرة/الكود فقط يكون أكثر تميزا وله الأفضلية.
وبالطبع كلما أختصرت المحاولة كلما كانت أفضل ولكن ليكن تركيزكم أولا على الحصول على النتيجة.
لك مبرمج محاولتين ولا يسمح برقع محاولة ثالثة.
لا تلجأوا إلى الذكاء الاصطناعي.
حل هذا المثال هو 73، حتى تستطيعوا مراجعة نتائجكم.
نريد نتائج للعدد: 10 و 500 و 7000

 

للمشرفين: أي كلمة في المشاركة محظورة يمكنكم تبديلها بأخرى بنفس المعنى.

[ناقل]

ههه ..... انا اشارك ام ممنوع من المشاركة 😷

[AbuuAhmed]

53 دقائق مضت, ناقل said:

ههه ..... انا اشارك ام ممنوع من المشاركة 😷

ولما لا؟!، أسمك مألوف لدي جيدا ولكن لا أتذكر أي أحداث بيني وبينك، والحمد لله من نعم الله علي أني كثير النسيان وهذا يسهل علي التعامل مع الناس.
أحييك على حماسك ولتكن أنت البادئ.

[Foksh]

2 ساعات مضت, AbuuAhmed said:

حل هذا المثال هو 73

وعليكم السلام ورحمة الله وبركاته ..

السؤال المنطقي هو ، في كم دورة تمت حتى وصل السجين 73 الناجي الوحيد !!!

[ناقل]

22 دقائق مضت, AbuuAhmed said:

ولما لا؟!، أسمك مألوف لدي جيدا ولكن لا أتذكر أي أحداث بيني وبينك، والحمد لله من نعم الله علي أني كثير النسيان وهذا يسهل علي التعامل مع الناس.
أحييك على حماسك ولتكن أنت البادئ.

اشكرك على الترحيب

ولكن دعني لاخر واحد في المشاركة 

لاني اعرف الاجابة مسبقا ..

اترك المجال للاخرين .. 

[Debug Ace]

بالنسبة للعدد 7000
النتيجة = 5809

بالنسبة للعدد 500
النتيجة = 489

بالنسبة للعدد 10
النتيجة = 5

[Debug Ace]

الكود

Public Function LastSurvivor(Optional ByVal lngN As Long = 10, Optional ByVal lngK As Long = 2) As Long
    Dim colPeople As Collection
    Dim lngIndex As Long
    Dim i As Long
    Dim killer As Long
    Dim totalCycles As Long
    Dim currentPosition As Long
    Set colPeople = New Collection
    For i = 1 To lngN
        colPeople.Add i
    Next i
    ReDim stepKilled(1 To lngN)
    lngIndex = 1
    currentPosition = 1
    totalCycles = 0
    Do While colPeople.count > 1
        lngIndex = ((lngIndex + lngK - 2) Mod colPeople.count) + 1
        If lngIndex = 1 Then
            killer = colPeople(colPeople.count)
        Else
            killer = colPeople(lngIndex - 1)
        End If
        If currentPosition > lngIndex Then
            totalCycles = totalCycles + 1
        End If
        currentPosition = lngIndex
        colPeople.Remove lngIndex
        If lngIndex > colPeople.count Then lngIndex = 1
    Loop
    LastSurvivor = colPeople(1)
End Function

الكود يعتمد على المصدر 

https://en.wikipedia.org/wiki/Josephus_problem

 

[AbuuAhmed]

1 ساعه مضت, Foksh said:

السؤال المنطقي هو ، في كم دورة تمت حتى وصل السجين 73 الناجي الوحيد !!!

أستاذ يمكن الوصول للحل بدون معرفة عدد الدورات.

[AbuuAhmed]

منذ ساعه, Debug Ace said:

الكود

الكود عمل محترف وسريع.
هناك مخالفتين منك 🙂 :
- بحثك عن الحل عن طريق الإنترنت.
- إضافة خيارات غير مطلوبة في السؤال بسبب اعتمادك على مصدر خارجي وبسببه طال الكود.
- يمكن اختصار الكود ورفعه كمشاركة ثانية وأخيرة.

إذا أنت من كتب الدالة وكتبتها بعد قراءتك للسؤال فأنت محترف وصانع متمكن للأكواد.
تعلمت من دالتك استخدام كائن Collection

[Debug Ace]

13 دقائق مضت, AbuuAhmed said:

الكود عمل محترف وسريع.
هناك مخالفتين منك 🙂 :
- بحثك عن الحل عن طريق الإنترنت.
- إضافة خيارات غير مطلوبة في السؤال بسبب اعتمادك على مصدر خارجي وبسببه طال الكود.
- يمكن اختصار الكود ورفعه كمشاركة ثانية وأخيرة.

إذا أنت من كتب الدالة وكتبتها بعد قراءتك للسؤال فأنت محترف وصانع متمكن للأكواد.
تعلمت من دالتك استخدام كائن Collection

- بحثك عن الحل عن طريق الإنترنت.

لم ابحث عن شئ أعرف القصة التاريخية فاللغز معروف باسم "مشكلة يوسف" نسبة إلى المؤرخ اليهودي يوسيفوس فلافيوس (Josephus Flavius)

فقط وضعت المصدر اثراء للموضوع وزيادة فى المعرفة

- إضافة خيارات غير مطلوبة في السؤال بسبب اعتمادك على مصدر خارجي وبسببه طال الكود.

لا توجد اضافات ولذلك تم التعامل معها كمعاملات اختيارية بقيم افتراضية بناء على طرحك الغير كامل اساسا لاصل اللغز بناء على المنطق الرياضى البحت لتكتمل الفائدة لمن يريد الزيادة والاستفادة 

وكان ايضا ذلك هو السبب الثانى لوضع المصدر 

ولذلك لا توجد اى مخالفات ولا اطالة بدون داع فى الكود

 

ونعم انا من كتبت الكود واشكرك على اطرائك 

تم تعديل أغسطس 23 بواسطه Debug Ace

[AbuuAhmed]

9 دقائق مضت, Debug Ace said:

لا توجد اضافات ولذلك تم التعامل معها كمعاملات اختيارية بقيم افتراضية بناء على طرحك الغير كامل اساسا لاصل اللغز

كان يجب عليك الإلتزام بالسؤال والشروط، هو سؤال وليس تنظيرا لنظرية ما.
لم تجب على الجزء الآخر من السؤال، هل كتب الدالة بعد قراءتك للسؤال أم كتبتها سابقا؟.

[Debug Ace]

ولمن يتسائل عن عدد الدورات 

Public Function LastSurvivor(Optional ByVal lngN As Long = 10, Optional ByVal lngK As Long = 2) As Long
    Dim colPeople As Collection
    Dim lngIndex As Long
    Dim i As Long
    Dim killer As Long
    Dim totalCycles As Long
    Dim currentPosition As Long
    Dim stepKilled() As Long
    Set colPeople = New Collection
    For i = 1 To lngN
        colPeople.Add i
    Next i
    ReDim stepKilled(1 To lngN)
    lngIndex = 1
    currentPosition = 1
    totalCycles = 0
    Do While colPeople.count > 1
        lngIndex = ((lngIndex + lngK - 2) Mod colPeople.count) + 1
        If lngIndex = 1 Then
            killer = colPeople(colPeople.count)
        Else
            killer = colPeople(lngIndex - 1)
        End If
        If currentPosition > lngIndex Then
            totalCycles = totalCycles + 1
        End If
        currentPosition = lngIndex
        stepKilled(colPeople(lngIndex)) = totalCycles + 1
        Debug.Print "السجين " & killer & " قتل السجين " & colPeople(lngIndex) & " (الدورة " & stepKilled(colPeople(lngIndex)) & ")"
        colPeople.Remove lngIndex
        If lngIndex > colPeople.count Then lngIndex = 1
    Loop
    LastSurvivor = colPeople(1)
Debug.Print "============"
    Debug.Print "الناجي الأخير هو السجين " & colPeople(1)
    Debug.Print "إجمالي عدد الدورات: " & totalCycles + 1

End Function

 

18 دقائق مضت, AbuuAhmed said:

كان يجب عليك الإلتزام بالسؤال والشروط، هو سؤال وليس تنظيرا لنظرية ما.
لم تجب على الجزء الآخر من السؤال، هل كتب الدالة بعد قراءتك للسؤال أم كتبتها سابقا؟.

اعتذر يبدو اننى لم احسن الفهم وتسرعت فى مسألة الشروط التى لم انتبه لها

وبالنسبة لاجابة السؤال الاخير:

اول مره اكتب هذه الوظيفة اساسا ولكن الموضوع يعتمد على الرياضيات البحته فى المقام الاول بدون فهم المنطق الرياضى لن تستطيع كتابة الكود

ومن أجل ذلك ايضا تعمدت وضع المصدر

تم تعديل أغسطس 23 بواسطه Debug Ace

[AbuuAhmed]

حلول ذكية منقولة

الحل الأول:
 

Function Survivor(pCount As Integer) As Variant
    Dim Res As String
    
    Survivor = "#NUM!"
    If pCount < 1 Or pCount > 511 Then Exit Function

    Res = WorksheetFunction.Dec2Bin(pCount)
    Res = Mid(Res, 2) & Left(Res, 1)
    Survivor = WorksheetFunction.Bin2Dec(Res)
End Function

الحل الثاني:
 

Function Survivor(pCount As Integer) As Integer
    Dim Prisoners As String
    Dim k As Integer, v As Integer
    
    Prisoners = String(pCount, "1")
    Do While Replace(Prisoners, "0", "") <> "1"
        k = InStr(v + 1, Prisoners, "1"): If k = 0 Then k = InStr(1, Prisoners, "1")
        v = InStr(k + 1, Prisoners, "1"): If v = 0 Then v = InStr(1, Prisoners, "1")
        Prisoners = Left(Prisoners, v - 1) & "0" & Mid(Prisoners, v + 1)
    Loop
    Survivor = InStr(1, Prisoners, "1")
End Function

آمل من المشرفين الكرام إقفال هذا الموضوع
فقد وئد في يومه الأول.
شكرا للجميع.

تم تعديل أغسطس 24 بواسطه AbuuAhmed

[ناقل]

وهذا حل ثالث اقصر 

Function JosephusOneLine(n As Integer) As Integer
    JosephusOneLine = 2 * (n - 2 ^ Int(Log(n) / Log(2))) + 1
End Function

 

[AbuuAhmed]

4 دقائق مضت, ناقل said:

وهذا حل ثالث اقصر 

هذا حل رياضياتي، وأنا أوضحت أننا نريد حلا برمجيا.
الغرض لنتعرف على قدارات المبرمجين ونرى "تحايلهم" في خلق افكار غير معتادة للوصول إلى الحل.
شكرا لك.